Protocol of Tezos in Coq Active development

These are the sources of the protocol of Tezos imported to Coq by the current development version of coq-of-ocaml. Tezos is a crypto-currency with smart-contracts and an upgradable protocol.

(2020-01-25) The import of Tezos code to Coq is currently on pause to consolitate gains (work on small features, write documentation). Our next targets will probably be the files with a lot of GADTs and the functors of the storage.

We show the original OCaml code on the left and the imported Coq code on the right. The imported code does not compile. Errors reported on the OCaml side are due to either various incompleteness in our tool, or to side-effects in the source code. Write at web [at] clarus [dot] me for more information. Work currently made at Nomadic Labs.

  • OCaml size: 35836 lines
  • Coq size: 49194 lines (+37% compared to OCaml)
  • errors from coq-of-ocaml: 2977

List of files

We add the errors from coq-of-ocaml as annotations. Errors from coq-of-ocaml are never fatal. They are not necessarly related to compilation bugs of the generated Coq files. These errors are either due to unsupported features in coq-of-ocaml or to side-effects in the source code.

Alpha_context

  • OCaml size: 279 lines
  • Coq size: 434 lines (+55% compared to OCaml)
alpha_context.ml 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Raw_context.t

type context = t

module type BASIC_DATA = sig
  type t

  include Compare.S with type t := t

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit
end

module Tez = Tez_repr
module Period = Period_repr

module Timestamp = struct
  include Time_repr

  let current = Raw_context.current_timestamp
end

include Operation_repr

module Operation = struct
  type 'kind t = 'kind operation = {
    shell : Operation.shell_header;
    protocol_data : 'kind protocol_data;
  }

  type packed = packed_operation

  let unsigned_encoding = unsigned_operation_encoding

  include Operation_repr
end

module Block_header = Block_header_repr

module Vote = struct
  include Vote_repr
  include Vote_storage
end

module Raw_level = Raw_level_repr
module Cycle = Cycle_repr
module Script_int = Script_int_repr

module Script_timestamp = struct
  include Script_timestamp_repr

  let now ctxt =
    let {Constants_repr.time_between_blocks; _} = Raw_context.constants ctxt in
    match time_between_blocks with
    | [] ->
        failwith
          "Internal error: 'time_between_block' constants is an empty list."
    | first_delay :: _ ->
        let current_timestamp = Raw_context.predecessor_timestamp ctxt in
        Time.add current_timestamp (Period_repr.to_seconds first_delay)
        |> Timestamp.to_seconds |> of_int64
end

module Script = struct
  include Michelson_v1_primitives
  include Script_repr

  let force_decode ctxt lexpr =
    Lwt.return
      ( Script_repr.force_decode lexpr
      >>? fun (v, cost) ->
      Raw_context.consume_gas ctxt cost >|? fun ctxt -> (v, ctxt) )

  let force_bytes ctxt lexpr =
    Lwt.return
      ( Script_repr.force_bytes lexpr
      >>? fun (b, cost) ->
      Raw_context.consume_gas ctxt cost >|? fun ctxt -> (b, ctxt) )

  module Legacy_support = Legacy_script_support_repr
end

module Fees = Fees_storage

type public_key = Signature.Public_key.t

type public_key_hash = Signature.Public_key_hash.t

type signature = Signature.t

module Constants = struct
  include Constants_repr
  include Constants_storage
end

module Voting_period = Voting_period_repr

module Gas = struct
  include Gas_limit_repr

  type error += Gas_limit_too_high = Raw_context.Gas_limit_too_high

  let check_limit = Raw_context.check_gas_limit

  let set_limit = Raw_context.set_gas_limit

  let set_unlimited = Raw_context.set_gas_unlimited

  let consume = Raw_context.consume_gas

  let check_enough = Raw_context.check_enough_gas

  let level = Raw_context.gas_level

  let consumed = Raw_context.gas_consumed

  let block_level = Raw_context.block_gas_level
end

module Level = struct
  include Level_repr
  include Level_storage
end

module Contract = struct
  include Contract_repr
  include Contract_storage

  let originate c contract ~balance ~script ~delegate =
    originate c contract ~balance ~script ~delegate

  let init_origination_nonce = Raw_context.init_origination_nonce

  let unset_origination_nonce = Raw_context.unset_origination_nonce
end

module Big_map = struct
  type id = Z.t

  let fresh = Storage.Big_map.Next.incr

  let fresh_temporary = Raw_context.fresh_temporary_big_map

  let mem c m k = Storage.Big_map.Contents.mem (c, m) k

  let get_opt c m k = Storage.Big_map.Contents.get_option (c, m) k

  let rpc_arg = Storage.Big_map.rpc_arg

  let cleanup_temporary c =
    Raw_context.temporary_big_maps c Storage.Big_map.remove_rec c
    >>= fun c -> Lwt.return (Raw_context.reset_temporary_big_map c)

  let exists c id =
    Lwt.return
      (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))
    >>=? fun c ->
    Storage.Big_map.Key_type.get_option c id
    >>=? fun kt ->
    match kt with
    | None ->
        return (c, None)
    | Some kt ->
        Storage.Big_map.Value_type.get c id
        >>=? fun kv -> return (c, Some (kt, kv))
end

module Delegate = Delegate_storage

module Roll = struct
  include Roll_repr
  include Roll_storage
end

module Nonce = Nonce_storage

module Seed = struct
  include Seed_repr
  include Seed_storage
end

module Fitness = struct
  include Fitness_repr
  include Fitness

  type fitness = t

  include Fitness_storage
end

module Bootstrap = Bootstrap_storage

module Commitment = struct
  include Commitment_repr
  include Commitment_storage
end

module Global = struct
  let get_block_priority = Storage.Block_priority.get

  let set_block_priority = Storage.Block_priority.set
end

let prepare_first_block = Init_storage.prepare_first_block

let prepare = Init_storage.prepare

let finalize ?commit_message:message c =
  let fitness = Fitness.from_int64 (Fitness.current c) in
  let context = Raw_context.recover c in
  {
    Updater.context;
    fitness;
    message;
    max_operations_ttl = 60;
    last_allowed_fork_level =
      Raw_level.to_int32 @@ Level.last_allowed_fork_level c;
  }

let activate = Raw_context.activate

let fork_test_chain = Raw_context.fork_test_chain

let record_endorsement = Raw_context.record_endorsement

let allowed_endorsements = Raw_context.allowed_endorsements

let init_endorsements = Raw_context.init_endorsements

let included_endorsements = Raw_context.included_endorsements

let reset_internal_nonce = Raw_context.reset_internal_nonce

let fresh_internal_nonce = Raw_context.fresh_internal_nonce

let record_internal_nonce = Raw_context.record_internal_nonce

let internal_nonce_already_recorded =
  Raw_context.internal_nonce_already_recorded

let add_deposit = Raw_context.add_deposit

let add_fees = Raw_context.add_fees

let add_rewards = Raw_context.add_rewards

let get_deposits = Raw_context.get_deposits

let get_fees = Raw_context.get_fees

let get_rewards = Raw_context.get_rewards

let description = Raw_context.description
Alpha_context.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Constants_repr.
Require Tezos.Contract_repr.
Require Tezos.Contract_storage.
Require Tezos.Gas_limit_repr.
Require Tezos.Init_storage.
Require Tezos.Period_repr.
Require Tezos.Raw_context.
Require Tezos.Script_repr.
Require Tezos.Storage.
Require Tezos.Storage_description.
Require Tezos.Tez_repr.

Definition t := Raw_context.t.

Definition context := t.

Module BASIC_DATA.
  Record signature {t : Set} := {
    t := t;
    op_eq : t -> t -> bool;
    op_ltgt : t -> t -> bool;
    op_lt : t -> t -> bool;
    op_lteq : t -> t -> bool;
    op_gteq : t -> t -> bool;
    op_gt : t -> t -> bool;
    compare : t -> t -> Z;
    equal : t -> t -> bool;
    max : t -> t -> t;
    min : t -> t -> t;
    encoding : Data_encoding.t t;
    pp : Format.formatter -> t -> unit;
  }.
  Arguments signature : clear implicits.
End BASIC_DATA.

Module Tez := Tez_repr.

Module Period := Period_repr.

Module Timestamp.
  Include Time_repr.
  
  Definition current : Raw_context.context -> Time.t :=
    Raw_context.current_timestamp.
End Timestamp.

Include Operation_repr.

Module Operation.
  Module t.
    Record record {kind : Set} := Build {
      shell : Operation.shell_header;
      protocol_data : protocol_data kind }.
    Arguments record : clear implicits.
    Definition with_shell {t_kind} shell (r : record t_kind) :=
      Build t_kind shell r.(protocol_data).
    Definition with_protocol_data {t_kind} protocol_data (r : record t_kind) :=
      Build t_kind r.(shell) protocol_data.
  End t.
  Definition t := t.record.
  
  Definition packed := packed_operation.
  
  Definition unsigned_encoding
    : Data_encoding.t (Operation.shell_header * packed_contents_list) :=
    unsigned_operation_encoding.
  
  Include Operation_repr.
End Operation.

Module Block_header := Block_header_repr.

Module Vote.
  Include Vote_repr.
  
  Include Vote_storage.
End Vote.

Module Raw_level := Raw_level_repr.

Module Cycle := Cycle_repr.

Module Script_int := Script_int_repr.

Module Script_timestamp.
  Include Script_timestamp_repr.
  
  Definition now (ctxt : Raw_context.context) : t :=
    let '{|
      Constants_repr.parametric.time_between_blocks := time_between_blocks
        |} := Raw_context.constants ctxt in
    match time_between_blocks with
    | [] =>
      Pervasives.failwith
        "Internal error: 'time_between_block' constants is an empty list."
    | cons first_delay _ =>
      let current_timestamp := Raw_context.predecessor_timestamp ctxt in
      Pervasives.op_pipegt
        (Pervasives.op_pipegt
          (Time.add current_timestamp (Period_repr.to_seconds first_delay))
          Timestamp.to_seconds) of_int64
    end.
End Script_timestamp.

Module Script.
  Include Michelson_v1_primitives.
  
  Include Script_repr.
  
  Definition force_decode
    (ctxt : Raw_context.context) (lexpr : Script_repr.lazy_expr)
    : Lwt.t (Error_monad.tzresult (Script_repr.expr * Raw_context.context)) :=
    Lwt.__return
      (Error_monad.op_gtgtquestion (Script_repr.force_decode lexpr)
        (fun function_parameter =>
          let '(v, cost) := function_parameter in
          Error_monad.op_gtpipequestion (Raw_context.consume_gas ctxt cost)
            (fun ctxt => (v, ctxt)))).
  
  Definition force_bytes
    (ctxt : Raw_context.context) (lexpr : Script_repr.lazy_expr)
    : Lwt.t (Error_monad.tzresult (MBytes.t * Raw_context.context)) :=
    Lwt.__return
      (Error_monad.op_gtgtquestion (Script_repr.force_bytes lexpr)
        (fun function_parameter =>
          let '(b, cost) := function_parameter in
          Error_monad.op_gtpipequestion (Raw_context.consume_gas ctxt cost)
            (fun ctxt => (b, ctxt)))).
  
  Module Legacy_support := Legacy_script_support_repr.
End Script.

Module Fees := Fees_storage.

Definition public_key := (|Signature.Public_key|).(S.SPublic_key.t).

Definition public_key_hash :=
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.t).

Definition signature := Signature.t.

Module Constants.
  Include Constants_repr.
  
  Include Constants_storage.
End Constants.

Module Voting_period := Voting_period_repr.

Module Gas.
  Include Gas_limit_repr.
  
  (* ❌ Structure item `typext` not handled. *)
  (* type_extension *)
  
  Definition check_limit : Raw_context.t -> Z.t -> Error_monad.tzresult unit :=
    Raw_context.check_gas_limit.
  
  Definition set_limit : Raw_context.t -> Z.t -> Raw_context.t :=
    Raw_context.set_gas_limit.
  
  Definition set_unlimited : Raw_context.t -> Raw_context.t :=
    Raw_context.set_gas_unlimited.
  
  Definition consume
    : Raw_context.context -> Gas_limit_repr.cost ->
    Error_monad.tzresult Raw_context.context := Raw_context.consume_gas.
  
  Definition check_enough
    : Raw_context.context -> Gas_limit_repr.cost -> Error_monad.tzresult unit :=
    Raw_context.check_enough_gas.
  
  Definition level : Raw_context.t -> Gas_limit_repr.t := Raw_context.gas_level.
  
  Definition consumed : Raw_context.t -> Raw_context.t -> Z.t :=
    Raw_context.gas_consumed.
  
  Definition block_level : Raw_context.t -> Z.t := Raw_context.block_gas_level.
End Gas.

Module Level.
  Include Level_repr.
  
  Include Level_storage.
End Level.

Module Contract.
  Include Contract_repr.
  
  Include Contract_storage.
  
  Definition originate
    (c : Raw_context.t) (contract : Contract_repr.t) (balance : Tez_repr.t)
    (script : Script_repr.t * option big_map_diff)
    (delegate : option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
    : Lwt.t (Error_monad.tzresult Raw_context.t) :=
    originate c None contract balance script delegate.
  
  Definition init_origination_nonce
    : Raw_context.t -> (|Operation_hash|).(S.HASH.t) -> Raw_context.t :=
    Raw_context.init_origination_nonce.
  
  Definition unset_origination_nonce : Raw_context.t -> Raw_context.t :=
    Raw_context.unset_origination_nonce.
End Contract.

Module Big_map.
  Definition id := Z.t.
  
  Definition fresh
    : Raw_context.t -> Lwt.t (Error_monad.tzresult (Raw_context.t * Z.t)) :=
    Storage.Big_map.Next.incr.
  
  Definition fresh_temporary
    : Raw_context.context -> Raw_context.context * Z.t :=
    Raw_context.fresh_temporary_big_map.
  
  Definition mem
    (c : Raw_context.t) (m : Z.t) (k : Storage.Big_map.Contents.key)
    : Lwt.t (Error_monad.tzresult (Raw_context.t * bool)) :=
    Storage.Big_map.Contents.mem (c, m) k.
  
  Definition get_opt
    (c : Raw_context.t) (m : Z.t) (k : Storage.Big_map.Contents.key)
    : Lwt.t
      (Error_monad.tzresult
        (Raw_context.t * option Storage.Big_map.Contents.value)) :=
    Storage.Big_map.Contents.get_option (c, m) k.
  
  Definition rpc_arg : RPC_arg.t Z.t := Storage.Big_map.rpc_arg.
  
  Definition cleanup_temporary (c : Raw_context.context)
    : Lwt.t Raw_context.context :=
    Error_monad.op_gtgteq
      (Raw_context.temporary_big_maps c Storage.Big_map.remove_rec c)
      (fun c => Lwt.__return (Raw_context.reset_temporary_big_map c)).
  
  Definition __exists
    (c : Raw_context.context) (id : Storage.Big_map.Key_type.key)
    : Lwt.t
      (Error_monad.tzresult
        (Raw_context.context *
          option
            (Storage.Big_map.Key_type.value * Storage.Big_map.Value_type.value))) :=
    Error_monad.op_gtgteqquestion
      (Lwt.__return
        (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)))
      (fun c =>
        Error_monad.op_gtgteqquestion (Storage.Big_map.Key_type.get_option c id)
          (fun kt =>
            match kt with
            | None => Error_monad.__return (c, None)
            | Some kt =>
              Error_monad.op_gtgteqquestion
                (Storage.Big_map.Value_type.get c id)
                (fun kv => Error_monad.__return (c, (Some (kt, kv))))
            end)).
End Big_map.

Module Delegate := Delegate_storage.

Module Roll.
  Include Roll_repr.
  
  Include Roll_storage.
End Roll.

Module Nonce := Nonce_storage.

Module Seed.
  Include Seed_repr.
  
  Include Seed_storage.
End Seed.

Module Fitness.
  Include Fitness_repr.
  
  Definition t := (|Fitness|).(S.T.t).
  
  Definition op_eq := (|Fitness|).(S.T.op_eq).
  
  Definition op_ltgt := (|Fitness|).(S.T.op_ltgt).
  
  Definition op_lt := (|Fitness|).(S.T.op_lt).
  
  Definition op_lteq := (|Fitness|).(S.T.op_lteq).
  
  Definition op_gteq := (|Fitness|).(S.T.op_gteq).
  
  Definition op_gt := (|Fitness|).(S.T.op_gt).
  
  Definition compare := (|Fitness|).(S.T.compare).
  
  Definition equal := (|Fitness|).(S.T.equal).
  
  Definition max := (|Fitness|).(S.T.max).
  
  Definition min := (|Fitness|).(S.T.min).
  
  Definition pp := (|Fitness|).(S.T.pp).
  
  Definition encoding := (|Fitness|).(S.T.encoding).
  
  Definition to_bytes := (|Fitness|).(S.T.to_bytes).
  
  Definition of_bytes := (|Fitness|).(S.T.of_bytes).
  
  Definition fitness := t.
  
  Include Fitness_storage.
End Fitness.

Module Bootstrap := Bootstrap_storage.

Module Commitment.
  Include Commitment_repr.
  
  Include Commitment_storage.
End Commitment.

Module Global.
  Definition get_block_priority
    : Raw_context.t -> Lwt.t (Error_monad.tzresult Z) :=
    Storage.Block_priority.get.
  
  Definition set_block_priority
    : Raw_context.t -> Z -> Lwt.t (Error_monad.tzresult Raw_context.t) :=
    Storage.Block_priority.set.
End Global.

Definition prepare_first_block
  : Context.t ->
  (Raw_context.t -> Script_repr.t ->
  Lwt.t
    (Error_monad.tzresult
      ((Script_repr.t * option Contract_storage.big_map_diff) * Raw_context.t)))
  -> int32 -> Time.t -> (|Fitness|).(S.T.t) ->
  Lwt.t (Error_monad.tzresult Raw_context.t) := Init_storage.prepare_first_block.

Definition prepare
  : Context.t -> Int32.t -> Time.t -> Time.t -> (|Fitness|).(S.T.t) ->
  Lwt.t (Error_monad.tzresult Raw_context.context) := Init_storage.prepare.

Definition finalize (message : option string) (c : Raw_context.context)
  : Updater.validation_result :=
  let fitness := Fitness.from_int64 (Fitness.current c) in
  let context := Raw_context.recover c in
  {| Updater.validation_result.context := context;
    Updater.validation_result.fitness := fitness;
    Updater.validation_result.message := message;
    Updater.validation_result.max_operations_ttl := 60;
    Updater.validation_result.last_allowed_fork_level :=
      Pervasives.op_atat Raw_level.to_int32 (Level.last_allowed_fork_level c) |}.

Definition activate
  : Raw_context.context -> (|Protocol_hash|).(S.HASH.t) -> Lwt.t Raw_context.t :=
  Raw_context.activate.

Definition fork_test_chain
  : Raw_context.context -> (|Protocol_hash|).(S.HASH.t) -> Time.t ->
  Lwt.t Raw_context.t := Raw_context.fork_test_chain.

Definition record_endorsement
  : Raw_context.context ->
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> Raw_context.context :=
  Raw_context.record_endorsement.

Definition allowed_endorsements
  : Raw_context.context ->
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.t)
    ((|Signature.Public_key|).(S.SPublic_key.t) * list Z * bool) :=
  Raw_context.allowed_endorsements.

Definition init_endorsements
  : Raw_context.context ->
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.t)
    ((|Signature.Public_key|).(S.SPublic_key.t) * list Z * bool) ->
  Raw_context.context := Raw_context.init_endorsements.

Definition included_endorsements : Raw_context.context -> Z :=
  Raw_context.included_endorsements.

Definition reset_internal_nonce : Raw_context.context -> Raw_context.context :=
  Raw_context.reset_internal_nonce.

Definition fresh_internal_nonce
  : Raw_context.context -> Error_monad.tzresult (Raw_context.context * Z) :=
  Raw_context.fresh_internal_nonce.

Definition record_internal_nonce
  : Raw_context.context -> Z -> Raw_context.context :=
  Raw_context.record_internal_nonce.

Definition internal_nonce_already_recorded : Raw_context.context -> Z -> bool :=
  Raw_context.internal_nonce_already_recorded.

Definition add_deposit
  : Raw_context.context ->
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> Tez_repr.t ->
  Lwt.t (Error_monad.tzresult Raw_context.context) := Raw_context.add_deposit.

Definition add_fees
  : Raw_context.context -> Tez_repr.t ->
  Lwt.t (Error_monad.tzresult Raw_context.context) := Raw_context.add_fees.

Definition add_rewards
  : Raw_context.context -> Tez_repr.t ->
  Lwt.t (Error_monad.tzresult Raw_context.context) := Raw_context.add_rewards.

Definition get_deposits
  : Raw_context.context ->
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.t)
    Tez_repr.t := Raw_context.get_deposits.

Definition get_fees : Raw_context.context -> Tez_repr.t := Raw_context.get_fees.

Definition get_rewards : Raw_context.context -> Tez_repr.t :=
  Raw_context.get_rewards.

Definition description : Storage_description.t Raw_context.context :=
  Raw_context.description.

Alpha_context_mli

  • OCaml size: 1390 lines
  • Coq size: 2502 lines (+80% compared to OCaml)
alpha_context.mli 13 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type BASIC_DATA = sig
  type t

  include Compare.S with type t := t

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit
end

type t

type context = t

type public_key = Signature.Public_key.t

type public_key_hash = Signature.Public_key_hash.t

type signature = Signature.t

module Tez : sig
  include BASIC_DATA

  type tez = t

  val zero : tez

  val one_mutez : tez

  val one_cent : tez

  val fifty_cents : tez

  val one : tez

  val ( -? ) : tez -> tez -> tez tzresult

  val ( +? ) : tez -> tez -> tez tzresult

  val ( *? ) : tez -> int64 -> tez tzresult

  val ( /? ) : tez -> int64 -> tez tzresult

  val of_string : string -> tez option

  val to_string : tez -> string

  val of_mutez : int64 -> tez option

  val to_mutez : tez -> int64
end

module Period : sig
  include BASIC_DATA

  type period = t

  val rpc_arg : period RPC_arg.arg

  val of_seconds : int64 -> period tzresult

  val to_seconds : period -> int64

  val mult : int32 -> period -> period tzresult

  val zero : period

  val one_second : period

  val one_minute : period

  val one_hour : period
end

module Timestamp : sig
  include BASIC_DATA with type t = Time.t

  type time = t

  val ( +? ) : time -> Period.t -> time tzresult

  val ( -? ) : time -> time -> Period.t tzresult

  val of_notation : string -> time option

  val to_notation : time -> string

  val of_seconds : string -> time option

  val to_seconds_string : time -> string

  val current : context -> time
end

module Raw_level : sig
  include BASIC_DATA

  type raw_level = t

  val rpc_arg : raw_level RPC_arg.arg

  val diff : raw_level -> raw_level -> int32

  val root : raw_level

  val succ : raw_level -> raw_level

  val pred : raw_level -> raw_level option

  val to_int32 : raw_level -> int32

  val of_int32 : int32 -> raw_level tzresult
end

module Cycle : sig
  include BASIC_DATA

  type cycle = t

  val rpc_arg : cycle RPC_arg.arg

  val root : cycle

  val succ : cycle -> cycle

  val pred : cycle -> cycle option

  val add : cycle -> int -> cycle

  val sub : cycle -> int -> cycle option

  val to_int32 : cycle -> int32

  module Map : S.MAP with type key = cycle
end

module Gas : sig
  type t = private Unaccounted | Limited of {remaining : Z.t}

  val encoding : t Data_encoding.encoding

  val pp : Format.formatter -> t -> unit

  type cost

  val cost_encoding : cost Data_encoding.encoding

  val pp_cost : Format.formatter -> cost -> unit

  type error += Block_quota_exceeded (* `Temporary *)

  type error += Operation_quota_exceeded (* `Temporary *)

  type error += Gas_limit_too_high (* `Permanent *)

  val free : cost

  val atomic_step_cost : int -> cost

  val step_cost : int -> cost

  val alloc_cost : int -> cost

  val alloc_bytes_cost : int -> cost

  val alloc_mbytes_cost : int -> cost

  val alloc_bits_cost : int -> cost

  val read_bytes_cost : Z.t -> cost

  val write_bytes_cost : Z.t -> cost

  val ( *@ ) : int -> cost -> cost

  val ( +@ ) : cost -> cost -> cost

  val check_limit : context -> Z.t -> unit tzresult

  val set_limit : context -> Z.t -> context

  val set_unlimited : context -> context

  val consume : context -> cost -> context tzresult

  val check_enough : context -> cost -> unit tzresult

  val level : context -> t

  val consumed : since:context -> until:context -> Z.t

  val block_level : context -> Z.t
end

module Script_int : module type of Script_int_repr

module Script_timestamp : sig
  open Script_int

  type t

  val compare : t -> t -> int

  val to_string : t -> string

  val to_notation : t -> string option

  val to_num_str : t -> string

  val of_string : string -> t option

  val diff : t -> t -> z num

  val add_delta : t -> z num -> t

  val sub_delta : t -> z num -> t

  val now : context -> t

  val to_zint : t -> Z.t

  val of_zint : Z.t -> t
end

module Script : sig
  type prim = Michelson_v1_primitives.prim =
    | K_parameter
    | K_storage
    | K_code
    | D_False
    | D_Elt
    | D_Left
    | D_None
    | D_Pair
    | D_Right
    | D_Some
    | D_True
    | D_Unit
    | I_PACK
    | I_UNPACK
    | I_BLAKE2B
    | I_SHA256
    | I_SHA512
    | I_ABS
    | I_ADD
    | I_AMOUNT
    | I_AND
    | I_BALANCE
    | I_CAR
    | I_CDR
    | I_CHAIN_ID
    | I_CHECK_SIGNATURE
    | I_COMPARE
    | I_CONCAT
    | I_CONS
    | I_CREATE_ACCOUNT
    | I_CREATE_CONTRACT
    | I_IMPLICIT_ACCOUNT
    | I_DIP
    | I_DROP
    | I_DUP
    | I_EDIV
    | I_EMPTY_BIG_MAP
    | I_EMPTY_MAP
    | I_EMPTY_SET
    | I_EQ
    | I_EXEC
    | I_APPLY
    | I_FAILWITH
    | I_GE
    | I_GET
    | I_GT
    | I_HASH_KEY
    | I_IF
    | I_IF_CONS
    | I_IF_LEFT
    | I_IF_NONE
    | I_INT
    | I_LAMBDA
    | I_LE
    | I_LEFT
    | I_LOOP
    | I_LSL
    | I_LSR
    | I_LT
    | I_MAP
    | I_MEM
    | I_MUL
    | I_NEG
    | I_NEQ
    | I_NIL
    | I_NONE
    | I_NOT
    | I_NOW
    | I_OR
    | I_PAIR
    | I_PUSH
    | I_RIGHT
    | I_SIZE
    | I_SOME
    | I_SOURCE
    | I_SENDER
    | I_SELF
    | I_SLICE
    | I_STEPS_TO_QUOTA
    | I_SUB
    | I_SWAP
    | I_TRANSFER_TOKENS
    | I_SET_DELEGATE
    | I_UNIT
    | I_UPDATE
    | I_XOR
    | I_ITER
    | I_LOOP_LEFT
    | I_ADDRESS
    | I_CONTRACT
    | I_ISNAT
    | I_CAST
    | I_RENAME
    | I_DIG
    | I_DUG
    | T_bool
    | T_contract
    | T_int
    | T_key
    | T_key_hash
    | T_lambda
    | T_list
    | T_map
    | T_big_map
    | T_nat
    | T_option
    | T_or
    | T_pair
    | T_set
    | T_signature
    | T_string
    | T_bytes
    | T_mutez
    | T_timestamp
    | T_unit
    | T_operation
    | T_address
    | T_chain_id

  type location = Micheline.canonical_location

  type annot = Micheline.annot

  type expr = prim Micheline.canonical

  type lazy_expr = expr Data_encoding.lazy_t

  val lazy_expr : expr -> lazy_expr

  type node = (location, prim) Micheline.node

  type t = {code : lazy_expr; storage : lazy_expr}

  val location_encoding : location Data_encoding.t

  val expr_encoding : expr Data_encoding.t

  val prim_encoding : prim Data_encoding.t

  val encoding : t Data_encoding.t

  val lazy_expr_encoding : lazy_expr Data_encoding.t

  val deserialized_cost : expr -> Gas.cost

  val serialized_cost : MBytes.t -> Gas.cost

  val traversal_cost : node -> Gas.cost

  val node_cost : node -> Gas.cost

  val int_node_cost : Z.t -> Gas.cost

  val int_node_cost_of_numbits : int -> Gas.cost

  val string_node_cost : string -> Gas.cost

  val string_node_cost_of_length : int -> Gas.cost

  val bytes_node_cost : MBytes.t -> Gas.cost

  val bytes_node_cost_of_length : int -> Gas.cost

  val prim_node_cost_nonrec : expr list -> annot -> Gas.cost

  val prim_node_cost_nonrec_of_length : int -> annot -> Gas.cost

  val seq_node_cost_nonrec : expr list -> Gas.cost

  val seq_node_cost_nonrec_of_length : int -> Gas.cost

  val minimal_deserialize_cost : lazy_expr -> Gas.cost

  val force_decode : context -> lazy_expr -> (expr * context) tzresult Lwt.t

  val force_bytes : context -> lazy_expr -> (MBytes.t * context) tzresult Lwt.t

  val unit_parameter : lazy_expr

  module Legacy_support : sig
    val manager_script_code : lazy_expr

    val add_do :
      manager_pkh:Signature.Public_key_hash.t ->
      script_code:lazy_expr ->
      script_storage:lazy_expr ->
      (lazy_expr * lazy_expr) tzresult Lwt.t

    val add_set_delegate :
      manager_pkh:Signature.Public_key_hash.t ->
      script_code:lazy_expr ->
      script_storage:lazy_expr ->
      (lazy_expr * lazy_expr) tzresult Lwt.t

    val has_default_entrypoint : lazy_expr -> bool

    val add_root_entrypoint : script_code:lazy_expr -> lazy_expr tzresult Lwt.t
  end
end

module Constants : sig
  (** Fixed constants *)
  type fixed = {
    proof_of_work_nonce_size : int;
    nonce_length : int;
    max_revelations_per_block : int;
    max_operation_data_length : int;
    max_proposals_per_delegate : int;
  }

  val fixed_encoding : fixed Data_encoding.t

  val fixed : fixed

  val proof_of_work_nonce_size : int

  val nonce_length : int

  val max_revelations_per_block : int

  val max_operation_data_length : int

  val max_proposals_per_delegate : int

  (** Constants parameterized by context *)
  type parametric = {
    preserved_cycles : int;
    blocks_per_cycle : int32;
    blocks_per_commitment : int32;
    blocks_per_roll_snapshot : int32;
    blocks_per_voting_period : int32;
    time_between_blocks : Period.t list;
    endorsers_per_block : int;
    hard_gas_limit_per_operation : Z.t;
    hard_gas_limit_per_block : Z.t;
    proof_of_work_threshold : int64;
    tokens_per_roll : Tez.t;
    michelson_maximum_type_size : int;
    seed_nonce_revelation_tip : Tez.t;
    origination_size : int;
    block_security_deposit : Tez.t;
    endorsement_security_deposit : Tez.t;
    block_reward : Tez.t;
    endorsement_reward : Tez.t;
    cost_per_byte : Tez.t;
    hard_storage_limit_per_operation : Z.t;
    test_chain_duration : int64;
    quorum_min : int32;
    quorum_max : int32;
    min_proposal_quorum : int32;
    initial_endorsers : int;
    delay_per_missing_endorsement : Period.t;
  }

  val parametric_encoding : parametric Data_encoding.t

  val parametric : context -> parametric

  val preserved_cycles : context -> int

  val blocks_per_cycle : context -> int32

  val blocks_per_commitment : context -> int32

  val blocks_per_roll_snapshot : context -> int32

  val blocks_per_voting_period : context -> int32

  val time_between_blocks : context -> Period.t list

  val endorsers_per_block : context -> int

  val initial_endorsers : context -> int

  val delay_per_missing_endorsement : context -> Period.t

  val hard_gas_limit_per_operation : context -> Z.t

  val hard_gas_limit_per_block : context -> Z.t

  val cost_per_byte : context -> Tez.t

  val hard_storage_limit_per_operation : context -> Z.t

  val proof_of_work_threshold : context -> int64

  val tokens_per_roll : context -> Tez.t

  val michelson_maximum_type_size : context -> int

  val block_reward : context -> Tez.t

  val endorsement_reward : context -> Tez.t

  val seed_nonce_revelation_tip : context -> Tez.t

  val origination_size : context -> int

  val block_security_deposit : context -> Tez.t

  val endorsement_security_deposit : context -> Tez.t

  val test_chain_duration : context -> int64

  val quorum_min : context -> int32

  val quorum_max : context -> int32

  val min_proposal_quorum : context -> int32

  (** All constants: fixed and parametric *)
  type t = {fixed : fixed; parametric : parametric}

  val encoding : t Data_encoding.t
end

module Voting_period : sig
  include BASIC_DATA

  type voting_period = t

  val rpc_arg : voting_period RPC_arg.arg

  val root : voting_period

  val succ : voting_period -> voting_period

  type kind = Proposal | Testing_vote | Testing | Promotion_vote

  val kind_encoding : kind Data_encoding.encoding

  val to_int32 : voting_period -> int32
end

module Level : sig
  type t = private {
    level : Raw_level.t;
    level_position : int32;
    cycle : Cycle.t;
    cycle_position : int32;
    voting_period : Voting_period.t;
    voting_period_position : int32;
    expected_commitment : bool;
  }

  include BASIC_DATA with type t := t

  val pp_full : Format.formatter -> t -> unit

  type level = t

  val root : context -> level

  val succ : context -> level -> level

  val pred : context -> level -> level option

  val from_raw : context -> ?offset:int32 -> Raw_level.t -> level

  val diff : level -> level -> int32

  val current : context -> level

  val last_level_in_cycle : context -> Cycle.t -> level

  val levels_in_cycle : context -> Cycle.t -> level list

  val levels_in_current_cycle : context -> ?offset:int32 -> unit -> level list

  val last_allowed_fork_level : context -> Raw_level.t
end

module Fitness : sig
  include module type of Fitness

  type fitness = t

  val increase : ?gap:int -> context -> context

  val current : context -> int64

  val to_int64 : fitness -> int64 tzresult
end

module Nonce : sig
  type t

  type nonce = t

  val encoding : nonce Data_encoding.t

  type unrevealed = {
    nonce_hash : Nonce_hash.t;
    delegate : public_key_hash;
    rewards : Tez.t;
    fees : Tez.t;
  }

  val record_hash : context -> unrevealed -> context tzresult Lwt.t

  val reveal : context -> Level.t -> nonce -> context tzresult Lwt.t

  type status = Unrevealed of unrevealed | Revealed of nonce

  val get : context -> Level.t -> status tzresult Lwt.t

  val of_bytes : MBytes.t -> nonce tzresult

  val hash : nonce -> Nonce_hash.t

  val check_hash : nonce -> Nonce_hash.t -> bool
end

module Seed : sig
  type seed

  type error +=
    | Unknown of {oldest : Cycle.t; cycle : Cycle.t; latest : Cycle.t}

  val for_cycle : context -> Cycle.t -> seed tzresult Lwt.t

  val cycle_end :
    context -> Cycle.t -> (context * Nonce.unrevealed list) tzresult Lwt.t

  val seed_encoding : seed Data_encoding.t
end

module Big_map : sig
  type id = Z.t

  val fresh : context -> (context * id) tzresult Lwt.t

  val fresh_temporary : context -> context * id

  val mem :
    context -> id -> Script_expr_hash.t -> (context * bool) tzresult Lwt.t

  val get_opt :
    context ->
    id ->
    Script_expr_hash.t ->
    (context * Script.expr option) tzresult Lwt.t

  val rpc_arg : id RPC_arg.t

  val cleanup_temporary : context -> context Lwt.t

  val exists :
    context ->
    id ->
    (context * (Script.expr * Script.expr) option) tzresult Lwt.t
end

module Contract : sig
  include BASIC_DATA

  type contract = t

  val rpc_arg : contract RPC_arg.arg

  val to_b58check : contract -> string

  val of_b58check : string -> contract tzresult

  val implicit_contract : public_key_hash -> contract

  val is_implicit : contract -> public_key_hash option

  val exists : context -> contract -> bool tzresult Lwt.t

  val must_exist : context -> contract -> unit tzresult Lwt.t

  val allocated : context -> contract -> bool tzresult Lwt.t

  val must_be_allocated : context -> contract -> unit tzresult Lwt.t

  val list : context -> contract list Lwt.t

  val get_manager_key : context -> public_key_hash -> public_key tzresult Lwt.t

  val is_manager_key_revealed :
    context -> public_key_hash -> bool tzresult Lwt.t

  val reveal_manager_key :
    context -> public_key_hash -> public_key -> context tzresult Lwt.t

  val get_script_code :
    context -> contract -> (context * Script.lazy_expr option) tzresult Lwt.t

  val get_script :
    context -> contract -> (context * Script.t option) tzresult Lwt.t

  val get_storage :
    context -> contract -> (context * Script.expr option) tzresult Lwt.t

  val get_counter : context -> public_key_hash -> Z.t tzresult Lwt.t

  val get_balance : context -> contract -> Tez.t tzresult Lwt.t

  val init_origination_nonce : context -> Operation_hash.t -> context

  val unset_origination_nonce : context -> context

  val fresh_contract_from_current_nonce :
    context -> (context * t) tzresult Lwt.t

  val originated_from_current_nonce :
    since:context -> until:context -> contract list tzresult Lwt.t

  type big_map_diff_item =
    | Update of {
        big_map : Big_map.id;
        diff_key : Script.expr;
        diff_key_hash : Script_expr_hash.t;
        diff_value : Script.expr option;
      }
    | Clear of Big_map.id
    | Copy of Big_map.id * Big_map.id
    | Alloc of {
        big_map : Big_map.id;
        key_type : Script.expr;
        value_type : Script.expr;
      }

  type big_map_diff = big_map_diff_item list

  val big_map_diff_encoding : big_map_diff Data_encoding.t

  val originate :
    context ->
    contract ->
    balance:Tez.t ->
    script:Script.t * big_map_diff option ->
    delegate:public_key_hash option ->
    context tzresult Lwt.t

  type error += Balance_too_low of contract * Tez.t * Tez.t

  val spend : context -> contract -> Tez.t -> context tzresult Lwt.t

  val credit : context -> contract -> Tez.t -> context tzresult Lwt.t

  val update_script_storage :
    context ->
    contract ->
    Script.expr ->
    big_map_diff option ->
    context tzresult Lwt.t

  val used_storage_space : context -> t -> Z.t tzresult Lwt.t

  val increment_counter : context -> public_key_hash -> context tzresult Lwt.t

  val check_counter_increment :
    context -> public_key_hash -> Z.t -> unit tzresult Lwt.t

  (**/**)

  (* Only for testing *)
  type origination_nonce

  val initial_origination_nonce : Operation_hash.t -> origination_nonce

  val originated_contract : origination_nonce -> contract
end

module Delegate : sig
  type balance =
    | Contract of Contract.t
    | Rewards of Signature.Public_key_hash.t * Cycle.t
    | Fees of Signature.Public_key_hash.t * Cycle.t
    | Deposits of Signature.Public_key_hash.t * Cycle.t

  type balance_update = Debited of Tez.t | Credited of Tez.t

  type balance_updates = (balance * balance_update) list

  val balance_updates_encoding : balance_updates Data_encoding.t

  val cleanup_balance_updates : balance_updates -> balance_updates

  val get : context -> Contract.t -> public_key_hash option tzresult Lwt.t

  val set :
    context -> Contract.t -> public_key_hash option -> context tzresult Lwt.t

  val fold :
    context -> init:'a -> f:(public_key_hash -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  val list : context -> public_key_hash list Lwt.t

  val freeze_deposit :
    context -> public_key_hash -> Tez.t -> context tzresult Lwt.t

  val freeze_rewards :
    context -> public_key_hash -> Tez.t -> context tzresult Lwt.t

  val freeze_fees :
    context -> public_key_hash -> Tez.t -> context tzresult Lwt.t

  val cycle_end :
    context ->
    Cycle.t ->
    Nonce.unrevealed list ->
    (context * balance_updates * Signature.Public_key_hash.t list) tzresult
    Lwt.t

  type frozen_balance = {deposit : Tez.t; fees : Tez.t; rewards : Tez.t}

  val punish :
    context ->
    public_key_hash ->
    Cycle.t ->
    (context * frozen_balance) tzresult Lwt.t

  val full_balance : context -> public_key_hash -> Tez.t tzresult Lwt.t

  val has_frozen_balance :
    context -> public_key_hash -> Cycle.t -> bool tzresult Lwt.t

  val frozen_balance : context -> public_key_hash -> Tez.t tzresult Lwt.t

  val frozen_balance_encoding : frozen_balance Data_encoding.t

  val frozen_balance_by_cycle_encoding :
    frozen_balance Cycle.Map.t Data_encoding.t

  val frozen_balance_by_cycle :
    context -> Signature.Public_key_hash.t -> frozen_balance Cycle.Map.t Lwt.t

  val staking_balance :
    context -> Signature.Public_key_hash.t -> Tez.t tzresult Lwt.t

  val delegated_contracts :
    context -> Signature.Public_key_hash.t -> Contract_repr.t list Lwt.t

  val delegated_balance :
    context -> Signature.Public_key_hash.t -> Tez.t tzresult Lwt.t

  val deactivated :
    context -> Signature.Public_key_hash.t -> bool tzresult Lwt.t

  val grace_period :
    context -> Signature.Public_key_hash.t -> Cycle.t tzresult Lwt.t
end

module Vote : sig
  type proposal = Protocol_hash.t

  val record_proposal :
    context -> Protocol_hash.t -> public_key_hash -> context tzresult Lwt.t

  val get_proposals : context -> int32 Protocol_hash.Map.t tzresult Lwt.t

  val clear_proposals : context -> context Lwt.t

  val recorded_proposal_count_for_delegate :
    context -> public_key_hash -> int tzresult Lwt.t

  val listings_encoding :
    (Signature.Public_key_hash.t * int32) list Data_encoding.t

  val freeze_listings : context -> context tzresult Lwt.t

  val clear_listings : context -> context tzresult Lwt.t

  val listing_size : context -> int32 tzresult Lwt.t

  val in_listings : context -> public_key_hash -> bool Lwt.t

  val get_listings : context -> (public_key_hash * int32) list Lwt.t

  type ballot = Yay | Nay | Pass

  val ballot_encoding : ballot Data_encoding.t

  type ballots = {yay : int32; nay : int32; pass : int32}

  val ballots_encoding : ballots Data_encoding.t

  val has_recorded_ballot : context -> public_key_hash -> bool Lwt.t

  val record_ballot :
    context -> public_key_hash -> ballot -> context tzresult Lwt.t

  val get_ballots : context -> ballots tzresult Lwt.t

  val get_ballot_list :
    context -> (Signature.Public_key_hash.t * ballot) list Lwt.t

  val clear_ballots : context -> context Lwt.t

  val get_current_period_kind : context -> Voting_period.kind tzresult Lwt.t

  val set_current_period_kind :
    context -> Voting_period.kind -> context tzresult Lwt.t

  val get_current_quorum : context -> int32 tzresult Lwt.t

  val get_participation_ema : context -> int32 tzresult Lwt.t

  val set_participation_ema : context -> int32 -> context tzresult Lwt.t

  val get_current_proposal : context -> proposal tzresult Lwt.t

  val init_current_proposal : context -> proposal -> context tzresult Lwt.t

  val clear_current_proposal : context -> context tzresult Lwt.t
end

module Block_header : sig
  type t = {shell : Block_header.shell_header; protocol_data : protocol_data}

  and protocol_data = {contents : contents; signature : Signature.t}

  and contents = {
    priority : int;
    seed_nonce_hash : Nonce_hash.t option;
    proof_of_work_nonce : MBytes.t;
  }

  type block_header = t

  type raw = Block_header.t

  type shell_header = Block_header.shell_header

  val raw : block_header -> raw

  val hash : block_header -> Block_hash.t

  val hash_raw : raw -> Block_hash.t

  val encoding : block_header Data_encoding.encoding

  val raw_encoding : raw Data_encoding.t

  val contents_encoding : contents Data_encoding.t

  val unsigned_encoding : (shell_header * contents) Data_encoding.t

  val protocol_data_encoding : protocol_data Data_encoding.encoding

  val shell_header_encoding : shell_header Data_encoding.encoding

  (** The maximum size of block headers in bytes *)
  val max_header_length : int
end

module Kind : sig
  type seed_nonce_revelation = Seed_nonce_revelation_kind

  type double_endorsement_evidence = Double_endorsement_evidence_kind

  type double_baking_evidence = Double_baking_evidence_kind

  type activate_account = Activate_account_kind

  type endorsement = Endorsement_kind

  type proposals = Proposals_kind

  type ballot = Ballot_kind

  type reveal = Reveal_kind

  type transaction = Transaction_kind

  type origination = Origination_kind

  type delegation = Delegation_kind

  type 'a manager =
    | Reveal_manager_kind : reveal manager
    | Transaction_manager_kind : transaction manager
    | Origination_manager_kind : origination manager
    | Delegation_manager_kind : delegation manager
end

type 'kind operation = {
  shell : Operation.shell_header;
  protocol_data : 'kind protocol_data;
}

and 'kind protocol_data = {
  contents : 'kind contents_list;
  signature : Signature.t option;
}

and _ contents_list =
  | Single : 'kind contents -> 'kind contents_list
  | Cons :
      'kind Kind.manager contents * 'rest Kind.manager contents_list
      -> ('kind * 'rest) Kind.manager contents_list

and _ contents =
  | Endorsement : {level : Raw_level.t} -> Kind.endorsement contents
  | Seed_nonce_revelation : {
      level : Raw_level.t;
      nonce : Nonce.t;
    }
      -> Kind.seed_nonce_revelation contents
  | Double_endorsement_evidence : {
      op1 : Kind.endorsement operation;
      op2 : Kind.endorsement operation;
    }
      -> Kind.double_endorsement_evidence contents
  | Double_baking_evidence : {
      bh1 : Block_header.t;
      bh2 : Block_header.t;
    }
      -> Kind.double_baking_evidence contents
  | Activate_account : {
      id : Ed25519.Public_key_hash.t;
      activation_code : Blinded_public_key_hash.activation_code;
    }
      -> Kind.activate_account contents
  | Proposals : {
      source : Signature.Public_key_hash.t;
      period : Voting_period.t;
      proposals : Protocol_hash.t list;
    }
      -> Kind.proposals contents
  | Ballot : {
      source : Signature.Public_key_hash.t;
      period : Voting_period.t;
      proposal : Protocol_hash.t;
      ballot : Vote.ballot;
    }
      -> Kind.ballot contents
  | Manager_operation : {
      source : Signature.Public_key_hash.t;
      fee : Tez.tez;
      counter : counter;
      operation : 'kind manager_operation;
      gas_limit : Z.t;
      storage_limit : Z.t;
    }
      -> 'kind Kind.manager contents

and _ manager_operation =
  | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation
  | Transaction : {
      amount : Tez.tez;
      parameters : Script.lazy_expr;
      entrypoint : string;
      destination : Contract.contract;
    }
      -> Kind.transaction manager_operation
  | Origination : {
      delegate : Signature.Public_key_hash.t option;
      script : Script.t;
      credit : Tez.tez;
      preorigination : Contract.t option;
    }
      -> Kind.origination manager_operation
  | Delegation :
      Signature.Public_key_hash.t option
      -> Kind.delegation manager_operation

and counter = Z.t

type 'kind internal_operation = {
  source : Contract.contract;
  operation : 'kind manager_operation;
  nonce : int;
}

type packed_manager_operation =
  | Manager : 'kind manager_operation -> packed_manager_operation

type packed_contents = Contents : 'kind contents -> packed_contents

type packed_contents_list =
  | Contents_list : 'kind contents_list -> packed_contents_list

type packed_protocol_data =
  | Operation_data : 'kind protocol_data -> packed_protocol_data

type packed_operation = {
  shell : Operation.shell_header;
  protocol_data : packed_protocol_data;
}

type packed_internal_operation =
  | Internal_operation : 'kind internal_operation -> packed_internal_operation

val manager_kind : 'kind manager_operation -> 'kind Kind.manager

module Fees : sig
  val origination_burn : context -> (context * Tez.t) tzresult Lwt.t

  val record_paid_storage_space :
    context -> Contract.t -> (context * Z.t * Z.t * Tez.t) tzresult Lwt.t

  val start_counting_storage_fees : context -> context

  val burn_storage_fees :
    context -> storage_limit:Z.t -> payer:Contract.t -> context tzresult Lwt.t

  type error += Cannot_pay_storage_fee (* `Temporary *)

  type error += Operation_quota_exceeded (* `Temporary *)

  type error += Storage_limit_too_high (* `Permanent *)

  val check_storage_limit : context -> storage_limit:Z.t -> unit tzresult
end

module Operation : sig
  type nonrec 'kind contents = 'kind contents

  type nonrec packed_contents = packed_contents

  val contents_encoding : packed_contents Data_encoding.t

  type nonrec 'kind protocol_data = 'kind protocol_data

  type nonrec packed_protocol_data = packed_protocol_data

  val protocol_data_encoding : packed_protocol_data Data_encoding.t

  val unsigned_encoding :
    (Operation.shell_header * packed_contents_list) Data_encoding.t

  type raw = Operation.t = {shell : Operation.shell_header; proto : MBytes.t}

  val raw_encoding : raw Data_encoding.t

  val contents_list_encoding : packed_contents_list Data_encoding.t

  type 'kind t = 'kind operation = {
    shell : Operation.shell_header;
    protocol_data : 'kind protocol_data;
  }

  type nonrec packed = packed_operation

  val encoding : packed Data_encoding.t

  val raw : _ operation -> raw

  val hash : _ operation -> Operation_hash.t

  val hash_raw : raw -> Operation_hash.t

  val hash_packed : packed_operation -> Operation_hash.t

  val acceptable_passes : packed_operation -> int list

  type error += Missing_signature (* `Permanent *)

  type error += Invalid_signature (* `Permanent *)

  val check_signature :
    public_key -> Chain_id.t -> _ operation -> unit tzresult Lwt.t

  val check_signature_sync :
    public_key -> Chain_id.t -> _ operation -> unit tzresult

  val internal_operation_encoding : packed_internal_operation Data_encoding.t

  val pack : 'kind operation -> packed_operation

  type ('a, 'b) eq = Eq : ('a, 'a) eq

  val equal : 'a operation -> 'b operation -> ('a, 'b) eq option

  module Encoding : sig
    type 'b case =
      | Case : {
          tag : int;
          name : string;
          encoding : 'a Data_encoding.t;
          select : packed_contents -> 'b contents option;
          proj : 'b contents -> 'a;
          inj : 'a -> 'b contents;
        }
          -> 'b case

    val endorsement_case : Kind.endorsement case

    val seed_nonce_revelation_case : Kind.seed_nonce_revelation case

    val double_endorsement_evidence_case :
      Kind.double_endorsement_evidence case

    val double_baking_evidence_case : Kind.double_baking_evidence case

    val activate_account_case : Kind.activate_account case

    val proposals_case : Kind.proposals case

    val ballot_case : Kind.ballot case

    val reveal_case : Kind.reveal Kind.manager case

    val transaction_case : Kind.transaction Kind.manager case

    val origination_case : Kind.origination Kind.manager case

    val delegation_case : Kind.delegation Kind.manager case

    module Manager_operations : sig
      type 'b case =
        | MCase : {
            tag : int;
            name : string;
            encoding : 'a Data_encoding.t;
            select :
              packed_manager_operation -> 'kind manager_operation option;
            proj : 'kind manager_operation -> 'a;
            inj : 'a -> 'kind manager_operation;
          }
            -> 'kind case

      val reveal_case : Kind.reveal case

      val transaction_case : Kind.transaction case

      val origination_case : Kind.origination case

      val delegation_case : Kind.delegation case
    end
  end

  val of_list : packed_contents list -> packed_contents_list

  val to_list : packed_contents_list -> packed_contents list
end

module Roll : sig
  type t = private int32

  type roll = t

  val encoding : roll Data_encoding.t

  val snapshot_rolls : context -> context tzresult Lwt.t

  val cycle_end : context -> Cycle.t -> context tzresult Lwt.t

  val baking_rights_owner :
    context -> Level.t -> priority:int -> public_key tzresult Lwt.t

  val endorsement_rights_owner :
    context -> Level.t -> slot:int -> public_key tzresult Lwt.t

  val delegate_pubkey : context -> public_key_hash -> public_key tzresult Lwt.t

  val get_rolls :
    context -> Signature.Public_key_hash.t -> roll list tzresult Lwt.t

  val get_change :
    context -> Signature.Public_key_hash.t -> Tez.t tzresult Lwt.t
end

module Commitment : sig
  type t = {
    blinded_public_key_hash : Blinded_public_key_hash.t;
    amount : Tez.tez;
  }

  val get_opt :
    context -> Blinded_public_key_hash.t -> Tez.t option tzresult Lwt.t

  val delete : context -> Blinded_public_key_hash.t -> context tzresult Lwt.t
end

module Bootstrap : sig
  val cycle_end : context -> Cycle.t -> context tzresult Lwt.t
end

module Global : sig
  val get_block_priority : context -> int tzresult Lwt.t

  val set_block_priority : context -> int -> context tzresult Lwt.t
end

val prepare_first_block :
  Context.t ->
  typecheck:(context ->
            Script.t ->
            ((Script.t * Contract.big_map_diff option) * context) tzresult
            Lwt.t) ->
  level:Int32.t ->
  timestamp:Time.t ->
  fitness:Fitness.t ->
  context tzresult Lwt.t

val prepare :
  Context.t ->
  level:Int32.t ->
  predecessor_timestamp:Time.t ->
  timestamp:Time.t ->
  fitness:Fitness.t ->
  context tzresult Lwt.t

val finalize : ?commit_message:string -> context -> Updater.validation_result

val activate : context -> Protocol_hash.t -> context Lwt.t

val fork_test_chain : context -> Protocol_hash.t -> Time.t -> context Lwt.t

val record_endorsement : context -> Signature.Public_key_hash.t -> context

val allowed_endorsements :
  context ->
  (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t

val init_endorsements :
  context ->
  (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ->
  context

val included_endorsements : context -> int

val reset_internal_nonce : context -> context

val fresh_internal_nonce : context -> (context * int) tzresult

val record_internal_nonce : context -> int -> context

val internal_nonce_already_recorded : context -> int -> bool

val add_fees : context -> Tez.t -> context tzresult Lwt.t

val add_rewards : context -> Tez.t -> context tzresult Lwt.t

val add_deposit :
  context -> Signature.Public_key_hash.t -> Tez.t -> context tzresult Lwt.t

val get_fees : context -> Tez.t

val get_rewards : context -> Tez.t

val get_deposits : context -> Tez.t Signature.Public_key_hash.Map.t

val description : context Storage_description.t
Alpha_context_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Blinded_public_key_hash.
Require Tezos.Contract_repr.
Require Tezos.Nonce_hash.
Require Tezos.Script_expr_hash.
Require Tezos.Storage_description.

Module BASIC_DATA.
  Record signature {t : Set} := {
    t := t;
    op_eq : t -> t -> bool;
    op_ltgt : t -> t -> bool;
    op_lt : t -> t -> bool;
    op_lteq : t -> t -> bool;
    op_gteq : t -> t -> bool;
    op_gt : t -> t -> bool;
    compare : t -> t -> Z;
    equal : t -> t -> bool;
    max : t -> t -> t;
    min : t -> t -> t;
    encoding : Data_encoding.t t;
    pp : Format.formatter -> t -> unit;
  }.
  Arguments signature : clear implicits.
End BASIC_DATA.

Parameter t : Set.

Definition context := t.

Definition public_key := (|Signature.Public_key|).(S.SPublic_key.t).

Definition public_key_hash :=
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.t).

Definition signature := Signature.t.

Module Tez.
  Parameter Included_BASIC_DATA : {t : _ & BASIC_DATA.signature t}.
  
  Definition t := (|Included_BASIC_DATA|).(BASIC_DATA.t).
  
  Definition op_eq := (|Included_BASIC_DATA|).(BASIC_DATA.op_eq).
  
  Definition op_ltgt := (|Included_BASIC_DATA|).(BASIC_DATA.op_ltgt).
  
  Definition op_lt := (|Included_BASIC_DATA|).(BASIC_DATA.op_lt).
  
  Definition op_lteq := (|Included_BASIC_DATA|).(BASIC_DATA.op_lteq).
  
  Definition op_gteq := (|Included_BASIC_DATA|).(BASIC_DATA.op_gteq).
  
  Definition op_gt := (|Included_BASIC_DATA|).(BASIC_DATA.op_gt).
  
  Definition compare := (|Included_BASIC_DATA|).(BASIC_DATA.compare).
  
  Definition equal := (|Included_BASIC_DATA|).(BASIC_DATA.equal).
  
  Definition max := (|Included_BASIC_DATA|).(BASIC_DATA.max).
  
  Definition min := (|Included_BASIC_DATA|).(BASIC_DATA.min).
  
  Definition encoding := (|Included_BASIC_DATA|).(BASIC_DATA.encoding).
  
  Definition pp := (|Included_BASIC_DATA|).(BASIC_DATA.pp).
  
  Definition tez := t.
  
  Parameter zero : tez.
  
  Parameter one_mutez : tez.
  
  Parameter one_cent : tez.
  
  Parameter fifty_cents : tez.
  
  Parameter one : tez.
  
  Parameter op_minusquestion : tez -> tez -> Error_monad.tzresult tez.
  
  Parameter op_plusquestion : tez -> tez -> Error_monad.tzresult tez.
  
  Parameter op_starquestion : tez -> int64 -> Error_monad.tzresult tez.
  
  Parameter op_divquestion : tez -> int64 -> Error_monad.tzresult tez.
  
  Parameter of_string : string -> option tez.
  
  Parameter to_string : tez -> string.
  
  Parameter of_mutez : int64 -> option tez.
  
  Parameter to_mutez : tez -> int64.
End Tez.

Module Period.
  Parameter Included_BASIC_DATA : {t : _ & BASIC_DATA.signature t}.
  
  Definition t := (|Included_BASIC_DATA|).(BASIC_DATA.t).
  
  Definition op_eq := (|Included_BASIC_DATA|).(BASIC_DATA.op_eq).
  
  Definition op_ltgt := (|Included_BASIC_DATA|).(BASIC_DATA.op_ltgt).
  
  Definition op_lt := (|Included_BASIC_DATA|).(BASIC_DATA.op_lt).
  
  Definition op_lteq := (|Included_BASIC_DATA|).(BASIC_DATA.op_lteq).
  
  Definition op_gteq := (|Included_BASIC_DATA|).(BASIC_DATA.op_gteq).
  
  Definition op_gt := (|Included_BASIC_DATA|).(BASIC_DATA.op_gt).
  
  Definition compare := (|Included_BASIC_DATA|).(BASIC_DATA.compare).
  
  Definition equal := (|Included_BASIC_DATA|).(BASIC_DATA.equal).
  
  Definition max := (|Included_BASIC_DATA|).(BASIC_DATA.max).
  
  Definition min := (|Included_BASIC_DATA|).(BASIC_DATA.min).
  
  Definition encoding := (|Included_BASIC_DATA|).(BASIC_DATA.encoding).
  
  Definition pp := (|Included_BASIC_DATA|).(BASIC_DATA.pp).
  
  Definition period := t.
  
  Parameter rpc_arg : RPC_arg.arg period.
  
  Parameter of_seconds : int64 -> Error_monad.tzresult period.
  
  Parameter to_seconds : period -> int64.
  
  Parameter mult : int32 -> period -> Error_monad.tzresult period.
  
  Parameter zero : period.
  
  Parameter one_second : period.
  
  Parameter one_minute : period.
  
  Parameter one_hour : period.
End Period.

Module Timestamp.
  Parameter Included_BASIC_DATA : {_ : unit & BASIC_DATA.signature Time.t}.
  
  Definition t := (|Included_BASIC_DATA|).(BASIC_DATA.t).
  
  Definition op_eq := (|Included_BASIC_DATA|).(BASIC_DATA.op_eq).
  
  Definition op_ltgt := (|Included_BASIC_DATA|).(BASIC_DATA.op_ltgt).
  
  Definition op_lt := (|Included_BASIC_DATA|).(BASIC_DATA.op_lt).
  
  Definition op_lteq := (|Included_BASIC_DATA|).(BASIC_DATA.op_lteq).
  
  Definition op_gteq := (|Included_BASIC_DATA|).(BASIC_DATA.op_gteq).
  
  Definition op_gt := (|Included_BASIC_DATA|).(BASIC_DATA.op_gt).
  
  Definition compare := (|Included_BASIC_DATA|).(BASIC_DATA.compare).
  
  Definition equal := (|Included_BASIC_DATA|).(BASIC_DATA.equal).
  
  Definition max := (|Included_BASIC_DATA|).(BASIC_DATA.max).
  
  Definition min := (|Included_BASIC_DATA|).(BASIC_DATA.min).
  
  Definition encoding := (|Included_BASIC_DATA|).(BASIC_DATA.encoding).
  
  Definition pp := (|Included_BASIC_DATA|).(BASIC_DATA.pp).
  
  Definition time := t.
  
  Parameter op_plusquestion : time -> Period.t -> Error_monad.tzresult time.
  
  Parameter op_minusquestion : time -> time -> Error_monad.tzresult Period.t.
  
  Parameter of_notation : string -> option time.
  
  Parameter to_notation : time -> string.
  
  Parameter of_seconds : string -> option time.
  
  Parameter to_seconds_string : time -> string.
  
  Parameter current : context -> time.
End Timestamp.

Module Raw_level.
  Parameter Included_BASIC_DATA : {t : _ & BASIC_DATA.signature t}.
  
  Definition t := (|Included_BASIC_DATA|).(BASIC_DATA.t).
  
  Definition op_eq := (|Included_BASIC_DATA|).(BASIC_DATA.op_eq).
  
  Definition op_ltgt := (|Included_BASIC_DATA|).(BASIC_DATA.op_ltgt).
  
  Definition op_lt := (|Included_BASIC_DATA|).(BASIC_DATA.op_lt).
  
  Definition op_lteq := (|Included_BASIC_DATA|).(BASIC_DATA.op_lteq).
  
  Definition op_gteq := (|Included_BASIC_DATA|).(BASIC_DATA.op_gteq).
  
  Definition op_gt := (|Included_BASIC_DATA|).(BASIC_DATA.op_gt).
  
  Definition compare := (|Included_BASIC_DATA|).(BASIC_DATA.compare).
  
  Definition equal := (|Included_BASIC_DATA|).(BASIC_DATA.equal).
  
  Definition max := (|Included_BASIC_DATA|).(BASIC_DATA.max).
  
  Definition min := (|Included_BASIC_DATA|).(BASIC_DATA.min).
  
  Definition encoding := (|Included_BASIC_DATA|).(BASIC_DATA.encoding).
  
  Definition pp := (|Included_BASIC_DATA|).(BASIC_DATA.pp).
  
  Definition raw_level := t.
  
  Parameter rpc_arg : RPC_arg.arg raw_level.
  
  Parameter diff : raw_level -> raw_level -> int32.
  
  Parameter root : raw_level.
  
  Parameter succ : raw_level -> raw_level.
  
  Parameter pred : raw_level -> option raw_level.
  
  Parameter to_int32 : raw_level -> int32.
  
  Parameter of_int32 : int32 -> Error_monad.tzresult raw_level.
End Raw_level.

Module Cycle.
  Parameter Included_BASIC_DATA : {t : _ & BASIC_DATA.signature t}.
  
  Definition t := (|Included_BASIC_DATA|).(BASIC_DATA.t).
  
  Definition op_eq := (|Included_BASIC_DATA|).(BASIC_DATA.op_eq).
  
  Definition op_ltgt := (|Included_BASIC_DATA|).(BASIC_DATA.op_ltgt).
  
  Definition op_lt := (|Included_BASIC_DATA|).(BASIC_DATA.op_lt).
  
  Definition op_lteq := (|Included_BASIC_DATA|).(BASIC_DATA.op_lteq).
  
  Definition op_gteq := (|Included_BASIC_DATA|).(BASIC_DATA.op_gteq).
  
  Definition op_gt := (|Included_BASIC_DATA|).(BASIC_DATA.op_gt).
  
  Definition compare := (|Included_BASIC_DATA|).(BASIC_DATA.compare).
  
  Definition equal := (|Included_BASIC_DATA|).(BASIC_DATA.equal).
  
  Definition max := (|Included_BASIC_DATA|).(BASIC_DATA.max).
  
  Definition min := (|Included_BASIC_DATA|).(BASIC_DATA.min).
  
  Definition encoding := (|Included_BASIC_DATA|).(BASIC_DATA.encoding).
  
  Definition pp := (|Included_BASIC_DATA|).(BASIC_DATA.pp).
  
  Definition cycle := t.
  
  Parameter rpc_arg : RPC_arg.arg cycle.
  
  Parameter root : cycle.
  
  Parameter succ : cycle -> cycle.
  
  Parameter pred : cycle -> option cycle.
  
  Parameter add : cycle -> Z -> cycle.
  
  Parameter sub : cycle -> Z -> option cycle.
  
  Parameter to_int32 : cycle -> int32.
  
  Parameter Map : {t : _ & S.MAP.signature cycle t}.
End Cycle.

Module Gas.
  Module t.
    Module Limited.
      Record record {remaining : Set} := {
        remaining : remaining }.
      Arguments record : clear implicits.
    End Limited.
    Definition Limited_skeleton := Limited.record.
  End t.
  
  Reserved Notation "'t.Limited".
  
  Inductive t : Set :=
  | Unaccounted : t
  | Limited : 't.Limited -> t
  
  where "'t.Limited" := (t.Limited_skeleton Z.t).
  
  Module ConstructorRecordNotations_t.
    Module t.
      Definition Limited := 't.Limited.
    End t.
  End ConstructorRecordNotations_t.
  Import ConstructorRecordNotations_t.
  
  Parameter encoding : Data_encoding.encoding t.
  
  Parameter pp : Format.formatter -> t -> unit.
  
  Parameter cost : Set.
  
  Parameter cost_encoding : Data_encoding.encoding cost.
  
  Parameter pp_cost : Format.formatter -> cost -> unit.
  
  (* extensible_type error *)
  
  (* extensible_type error *)
  
  (* extensible_type error *)
  
  Parameter free : cost.
  
  Parameter atomic_step_cost : Z -> cost.
  
  Parameter step_cost : Z -> cost.
  
  Parameter alloc_cost : Z -> cost.
  
  Parameter alloc_bytes_cost : Z -> cost.
  
  Parameter alloc_mbytes_cost : Z -> cost.
  
  Parameter alloc_bits_cost : Z -> cost.
  
  Parameter read_bytes_cost : Z.t -> cost.
  
  Parameter write_bytes_cost : Z.t -> cost.
  
  Parameter op_starat : Z -> cost -> cost.
  
  Parameter op_plusat : cost -> cost -> cost.
  
  Parameter check_limit : context -> Z.t -> Error_monad.tzresult unit.
  
  Parameter set_limit : context -> Z.t -> context.
  
  Parameter set_unlimited : context -> context.
  
  Parameter consume : context -> cost -> Error_monad.tzresult context.
  
  Parameter check_enough : context -> cost -> Error_monad.tzresult unit.
  
  Parameter level : context -> t.
  
  Parameter consumed : context -> context -> Z.t.
  
  Parameter block_level : context -> Z.t.
End Gas.

Parameter Script_int : typeof.

Module Script_timestamp.
  Parameter t : Set.
  
  Parameter compare : t -> t -> Z.
  
  Parameter to_string : t -> string.
  
  Parameter to_notation : t -> option string.
  
  Parameter to_num_str : t -> string.
  
  Parameter of_string : string -> option t.
  
  Parameter diff : t -> t -> Script_int.num Script_int.z.
  
  Parameter add_delta : t -> Script_int.num Script_int.z -> t.
  
  Parameter sub_delta : t -> Script_int.num Script_int.z -> t.
  
  Parameter now : context -> t.
  
  Parameter to_zint : t -> Z.t.
  
  Parameter of_zint : Z.t -> t.
End Script_timestamp.

Module Script.
  Inductive prim : Set :=
  | K_parameter : prim
  | K_storage : prim
  | K_code : prim
  | D_False : prim
  | D_Elt : prim
  | D_Left : prim
  | D_None : prim
  | D_Pair : prim
  | D_Right : prim
  | D_Some : prim
  | D_True : prim
  | D_Unit : prim
  | I_PACK : prim
  | I_UNPACK : prim
  | I_BLAKE2B : prim
  | I_SHA256 : prim
  | I_SHA512 : prim
  | I_ABS : prim
  | I_ADD : prim
  | I_AMOUNT : prim
  | I_AND : prim
  | I_BALANCE : prim
  | I_CAR : prim
  | I_CDR : prim
  | I_CHAIN_ID : prim
  | I_CHECK_SIGNATURE : prim
  | I_COMPARE : prim
  | I_CONCAT : prim
  | I_CONS : prim
  | I_CREATE_ACCOUNT : prim
  | I_CREATE_CONTRACT : prim
  | I_IMPLICIT_ACCOUNT : prim
  | I_DIP : prim
  | I_DROP : prim
  | I_DUP : prim
  | I_EDIV : prim
  | I_EMPTY_BIG_MAP : prim
  | I_EMPTY_MAP : prim
  | I_EMPTY_SET : prim
  | I_EQ : prim
  | I_EXEC : prim
  | I_APPLY : prim
  | I_FAILWITH : prim
  | I_GE : prim
  | I_GET : prim
  | I_GT : prim
  | I_HASH_KEY : prim
  | I_IF : prim
  | I_IF_CONS : prim
  | I_IF_LEFT : prim
  | I_IF_NONE : prim
  | I_INT : prim
  | I_LAMBDA : prim
  | I_LE : prim
  | I_LEFT : prim
  | I_LOOP : prim
  | I_LSL : prim
  | I_LSR : prim
  | I_LT : prim
  | I_MAP : prim
  | I_MEM : prim
  | I_MUL : prim
  | I_NEG : prim
  | I_NEQ : prim
  | I_NIL : prim
  | I_NONE : prim
  | I_NOT : prim
  | I_NOW : prim
  | I_OR : prim
  | I_PAIR : prim
  | I_PUSH : prim
  | I_RIGHT : prim
  | I_SIZE : prim
  | I_SOME : prim
  | I_SOURCE : prim
  | I_SENDER : prim
  | I_SELF : prim
  | I_SLICE : prim
  | I_STEPS_TO_QUOTA : prim
  | I_SUB : prim
  | I_SWAP : prim
  | I_TRANSFER_TOKENS : prim
  | I_SET_DELEGATE : prim
  | I_UNIT : prim
  | I_UPDATE : prim
  | I_XOR : prim
  | I_ITER : prim
  | I_LOOP_LEFT : prim
  | I_ADDRESS : prim
  | I_CONTRACT : prim
  | I_ISNAT : prim
  | I_CAST : prim
  | I_RENAME : prim
  | I_DIG : prim
  | I_DUG : prim
  | T_bool : prim
  | T_contract : prim
  | T_int : prim
  | T_key : prim
  | T_key_hash : prim
  | T_lambda : prim
  | T_list : prim
  | T_map : prim
  | T_big_map : prim
  | T_nat : prim
  | T_option : prim
  | T_or : prim
  | T_pair : prim
  | T_set : prim
  | T_signature : prim
  | T_string : prim
  | T_bytes : prim
  | T_mutez : prim
  | T_timestamp : prim
  | T_unit : prim
  | T_operation : prim
  | T_address : prim
  | T_chain_id : prim.
  
  Definition location := Micheline.canonical_location.
  
  Definition annot := Micheline.annot.
  
  Definition expr := Micheline.canonical prim.
  
  Definition lazy_expr := Data_encoding.lazy_t expr.
  
  Parameter __lazy_expr_value : expr -> lazy_expr.
  
  Definition node := Micheline.node location prim.
  
  Module t.
    Record record := Build {
      code : lazy_expr;
      storage : lazy_expr }.
    Definition with_code code (r : record) :=
      Build code r.(storage).
    Definition with_storage storage (r : record) :=
      Build r.(code) storage.
  End t.
  Definition t := t.record.
  
  Parameter location_encoding : Data_encoding.t location.
  
  Parameter expr_encoding : Data_encoding.t expr.
  
  Parameter prim_encoding : Data_encoding.t prim.
  
  Parameter encoding : Data_encoding.t t.
  
  Parameter lazy_expr_encoding : Data_encoding.t lazy_expr.
  
  Parameter deserialized_cost : expr -> Gas.cost.
  
  Parameter serialized_cost : MBytes.t -> Gas.cost.
  
  Parameter traversal_cost : node -> Gas.cost.
  
  Parameter node_cost : node -> Gas.cost.
  
  Parameter int_node_cost : Z.t -> Gas.cost.
  
  Parameter int_node_cost_of_numbits : Z -> Gas.cost.
  
  Parameter string_node_cost : string -> Gas.cost.
  
  Parameter string_node_cost_of_length : Z -> Gas.cost.
  
  Parameter bytes_node_cost : MBytes.t -> Gas.cost.
  
  Parameter bytes_node_cost_of_length : Z -> Gas.cost.
  
  Parameter prim_node_cost_nonrec : list expr -> annot -> Gas.cost.
  
  Parameter prim_node_cost_nonrec_of_length : Z -> annot -> Gas.cost.
  
  Parameter seq_node_cost_nonrec : list expr -> Gas.cost.
  
  Parameter seq_node_cost_nonrec_of_length : Z -> Gas.cost.
  
  Parameter minimal_deserialize_cost : lazy_expr -> Gas.cost.
  
  Parameter force_decode :
    context -> lazy_expr -> Lwt.t (Error_monad.tzresult (expr * context)).
  
  Parameter force_bytes :
    context -> lazy_expr -> Lwt.t (Error_monad.tzresult (MBytes.t * context)).
  
  Parameter unit_parameter : lazy_expr.
  
  Module Legacy_support.
    Parameter manager_script_code : lazy_expr.
    
    Parameter add_do :
      (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> lazy_expr ->
      lazy_expr -> Lwt.t (Error_monad.tzresult (lazy_expr * lazy_expr)).
    
    Parameter add_set_delegate :
      (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> lazy_expr ->
      lazy_expr -> Lwt.t (Error_monad.tzresult (lazy_expr * lazy_expr)).
    
    Parameter has_default_entrypoint : lazy_expr -> bool.
    
    Parameter add_root_entrypoint :
      lazy_expr -> Lwt.t (Error_monad.tzresult lazy_expr).
  End Legacy_support.
End Script.

Module Constants.
  Module fixed.
    Record record := Build {
      proof_of_work_nonce_size : Z;
      nonce_length : Z;
      max_revelations_per_block : Z;
      max_operation_data_length : Z;
      max_proposals_per_delegate : Z }.
    Definition with_proof_of_work_nonce_size proof_of_work_nonce_size
      (r : record) :=
      Build proof_of_work_nonce_size r.(nonce_length)
        r.(max_revelations_per_block) r.(max_operation_data_length)
        r.(max_proposals_per_delegate).
    Definition with_nonce_length nonce_length (r : record) :=
      Build r.(proof_of_work_nonce_size) nonce_length
        r.(max_revelations_per_block) r.(max_operation_data_length)
        r.(max_proposals_per_delegate).
    Definition with_max_revelations_per_block max_revelations_per_block
      (r : record) :=
      Build r.(proof_of_work_nonce_size) r.(nonce_length)
        max_revelations_per_block r.(max_operation_data_length)
        r.(max_proposals_per_delegate).
    Definition with_max_operation_data_length max_operation_data_length
      (r : record) :=
      Build r.(proof_of_work_nonce_size) r.(nonce_length)
        r.(max_revelations_per_block) max_operation_data_length
        r.(max_proposals_per_delegate).
    Definition with_max_proposals_per_delegate max_proposals_per_delegate
      (r : record) :=
      Build r.(proof_of_work_nonce_size) r.(nonce_length)
        r.(max_revelations_per_block) r.(max_operation_data_length)
        max_proposals_per_delegate.
  End fixed.
  Definition fixed := fixed.record.
  
  Parameter fixed_encoding : Data_encoding.t fixed.
  
  Parameter __fixed_value : fixed.
  
  Parameter proof_of_work_nonce_size : Z.
  
  Parameter nonce_length : Z.
  
  Parameter max_revelations_per_block : Z.
  
  Parameter max_operation_data_length : Z.
  
  Parameter max_proposals_per_delegate : Z.
  
  Module parametric.
    Record record := Build {
      preserved_cycles : Z;
      blocks_per_cycle : int32;
      blocks_per_commitment : int32;
      blocks_per_roll_snapshot : int32;
      blocks_per_voting_period : int32;
      time_between_blocks : list Period.t;
      endorsers_per_block : Z;
      hard_gas_limit_per_operation : Z.t;
      hard_gas_limit_per_block : Z.t;
      proof_of_work_threshold : int64;
      tokens_per_roll : Tez.t;
      michelson_maximum_type_size : Z;
      seed_nonce_revelation_tip : Tez.t;
      origination_size : Z;
      block_security_deposit : Tez.t;
      endorsement_security_deposit : Tez.t;
      block_reward : Tez.t;
      endorsement_reward : Tez.t;
      cost_per_byte : Tez.t;
      hard_storage_limit_per_operation : Z.t;
      test_chain_duration : int64;
      quorum_min : int32;
      quorum_max : int32;
      min_proposal_quorum : int32;
      initial_endorsers : Z;
      delay_per_missing_endorsement : Period.t }.
    Definition with_preserved_cycles preserved_cycles (r : record) :=
      Build preserved_cycles r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_blocks_per_cycle blocks_per_cycle (r : record) :=
      Build r.(preserved_cycles) blocks_per_cycle r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_blocks_per_commitment blocks_per_commitment (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) blocks_per_commitment
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_blocks_per_roll_snapshot blocks_per_roll_snapshot
      (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        blocks_per_roll_snapshot r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_blocks_per_voting_period blocks_per_voting_period
      (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) blocks_per_voting_period
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_time_between_blocks time_between_blocks (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        time_between_blocks r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_endorsers_per_block endorsers_per_block (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) endorsers_per_block
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_hard_gas_limit_per_operation hard_gas_limit_per_operation
      (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        hard_gas_limit_per_operation r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_hard_gas_limit_per_block hard_gas_limit_per_block
      (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) hard_gas_limit_per_block
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_proof_of_work_threshold proof_of_work_threshold
      (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        proof_of_work_threshold r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_tokens_per_roll tokens_per_roll (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) tokens_per_roll
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_michelson_maximum_type_size michelson_maximum_type_size
      (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        michelson_maximum_type_size r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_seed_nonce_revelation_tip seed_nonce_revelation_tip
      (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) seed_nonce_revelation_tip
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_origination_size origination_size (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        origination_size r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_block_security_deposit block_security_deposit
      (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) block_security_deposit
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_endorsement_security_deposit endorsement_security_deposit
      (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        endorsement_security_deposit r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_block_reward block_reward (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) block_reward r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_endorsement_reward endorsement_reward (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) endorsement_reward
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_cost_per_byte cost_per_byte (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        cost_per_byte r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_hard_storage_limit_per_operation
      hard_storage_limit_per_operation (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) hard_storage_limit_per_operation
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_test_chain_duration test_chain_duration (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        test_chain_duration r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_quorum_min quorum_min (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) quorum_min r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_quorum_max quorum_max (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) quorum_max
        r.(min_proposal_quorum) r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_min_proposal_quorum min_proposal_quorum (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        min_proposal_quorum r.(initial_endorsers)
        r.(delay_per_missing_endorsement).
    Definition with_initial_endorsers initial_endorsers (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) initial_endorsers
        r.(delay_per_missing_endorsement).
    Definition with_delay_per_missing_endorsement delay_per_missing_endorsement
      (r : record) :=
      Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
        r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
        r.(time_between_blocks) r.(endorsers_per_block)
        r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
        r.(proof_of_work_threshold) r.(tokens_per_roll)
        r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
        r.(origination_size) r.(block_security_deposit)
        r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
        r.(cost_per_byte) r.(hard_storage_limit_per_operation)
        r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
        r.(min_proposal_quorum) r.(initial_endorsers)
        delay_per_missing_endorsement.
  End parametric.
  Definition parametric := parametric.record.
  
  Parameter parametric_encoding : Data_encoding.t parametric.
  
  Parameter parametric : context -> parametric.
  
  Parameter preserved_cycles : context -> Z.
  
  Parameter blocks_per_cycle : context -> int32.
  
  Parameter blocks_per_commitment : context -> int32.
  
  Parameter blocks_per_roll_snapshot : context -> int32.
  
  Parameter blocks_per_voting_period : context -> int32.
  
  Parameter time_between_blocks : context -> list Period.t.
  
  Parameter endorsers_per_block : context -> Z.
  
  Parameter initial_endorsers : context -> Z.
  
  Parameter delay_per_missing_endorsement : context -> Period.t.
  
  Parameter hard_gas_limit_per_operation : context -> Z.t.
  
  Parameter hard_gas_limit_per_block : context -> Z.t.
  
  Parameter cost_per_byte : context -> Tez.t.
  
  Parameter hard_storage_limit_per_operation : context -> Z.t.
  
  Parameter proof_of_work_threshold : context -> int64.
  
  Parameter tokens_per_roll : context -> Tez.t.
  
  Parameter michelson_maximum_type_size : context -> Z.
  
  Parameter block_reward : context -> Tez.t.
  
  Parameter endorsement_reward : context -> Tez.t.
  
  Parameter seed_nonce_revelation_tip : context -> Tez.t.
  
  Parameter origination_size : context -> Z.
  
  Parameter block_security_deposit : context -> Tez.t.
  
  Parameter endorsement_security_deposit : context -> Tez.t.
  
  Parameter test_chain_duration : context -> int64.
  
  Parameter quorum_min : context -> int32.
  
  Parameter quorum_max : context -> int32.
  
  Parameter min_proposal_quorum : context -> int32.
  
  Module t.
    Record record := Build {
      fixed : fixed;
      parametric : parametric }.
    Definition with_fixed fixed (r : record) :=
      Build fixed r.(parametric).
    Definition with_parametric parametric (r : record) :=
      Build r.(fixed) parametric.
  End t.
  Definition t := t.record.
  
  Parameter encoding : Data_encoding.t t.
End Constants.

Module Voting_period.
  Parameter Included_BASIC_DATA : {t : _ & BASIC_DATA.signature t}.
  
  Definition t := (|Included_BASIC_DATA|).(BASIC_DATA.t).
  
  Definition op_eq := (|Included_BASIC_DATA|).(BASIC_DATA.op_eq).
  
  Definition op_ltgt := (|Included_BASIC_DATA|).(BASIC_DATA.op_ltgt).
  
  Definition op_lt := (|Included_BASIC_DATA|).(BASIC_DATA.op_lt).
  
  Definition op_lteq := (|Included_BASIC_DATA|).(BASIC_DATA.op_lteq).
  
  Definition op_gteq := (|Included_BASIC_DATA|).(BASIC_DATA.op_gteq).
  
  Definition op_gt := (|Included_BASIC_DATA|).(BASIC_DATA.op_gt).
  
  Definition compare := (|Included_BASIC_DATA|).(BASIC_DATA.compare).
  
  Definition equal := (|Included_BASIC_DATA|).(BASIC_DATA.equal).
  
  Definition max := (|Included_BASIC_DATA|).(BASIC_DATA.max).
  
  Definition min := (|Included_BASIC_DATA|).(BASIC_DATA.min).
  
  Definition encoding := (|Included_BASIC_DATA|).(BASIC_DATA.encoding).
  
  Definition pp := (|Included_BASIC_DATA|).(BASIC_DATA.pp).
  
  Definition voting_period := t.
  
  Parameter rpc_arg : RPC_arg.arg voting_period.
  
  Parameter root : voting_period.
  
  Parameter succ : voting_period -> voting_period.
  
  Inductive kind : Set :=
  | Proposal : kind
  | Testing_vote : kind
  | Testing : kind
  | Promotion_vote : kind.
  
  Parameter kind_encoding : Data_encoding.encoding kind.
  
  Parameter to_int32 : voting_period -> int32.
End Voting_period.

Module Level.
  Module t.
    Record record := Build {
      level : Raw_level.t;
      level_position : int32;
      cycle : Cycle.t;
      cycle_position : int32;
      voting_period : Voting_period.t;
      voting_period_position : int32;
      expected_commitment : bool }.
    Definition with_level level (r : record) :=
      Build level r.(level_position) r.(cycle) r.(cycle_position)
        r.(voting_period) r.(voting_period_position) r.(expected_commitment).
    Definition with_level_position level_position (r : record) :=
      Build r.(level) level_position r.(cycle) r.(cycle_position)
        r.(voting_period) r.(voting_period_position) r.(expected_commitment).
    Definition with_cycle cycle (r : record) :=
      Build r.(level) r.(level_position) cycle r.(cycle_position)
        r.(voting_period) r.(voting_period_position) r.(expected_commitment).
    Definition with_cycle_position cycle_position (r : record) :=
      Build r.(level) r.(level_position) r.(cycle) cycle_position
        r.(voting_period) r.(voting_period_position) r.(expected_commitment).
    Definition with_voting_period voting_period (r : record) :=
      Build r.(level) r.(level_position) r.(cycle) r.(cycle_position)
        voting_period r.(voting_period_position) r.(expected_commitment).
    Definition with_voting_period_position voting_period_position
      (r : record) :=
      Build r.(level) r.(level_position) r.(cycle) r.(cycle_position)
        r.(voting_period) voting_period_position r.(expected_commitment).
    Definition with_expected_commitment expected_commitment (r : record) :=
      Build r.(level) r.(level_position) r.(cycle) r.(cycle_position)
        r.(voting_period) r.(voting_period_position) expected_commitment.
  End t.
  Definition t := t.record.
  
  Parameter Included_BASIC_DATA : {_ : unit & BASIC_DATA.signature t}.
  
  Definition op_eq := (|Included_BASIC_DATA|).(BASIC_DATA.op_eq).
  
  Definition op_ltgt := (|Included_BASIC_DATA|).(BASIC_DATA.op_ltgt).
  
  Definition op_lt := (|Included_BASIC_DATA|).(BASIC_DATA.op_lt).
  
  Definition op_lteq := (|Included_BASIC_DATA|).(BASIC_DATA.op_lteq).
  
  Definition op_gteq := (|Included_BASIC_DATA|).(BASIC_DATA.op_gteq).
  
  Definition op_gt := (|Included_BASIC_DATA|).(BASIC_DATA.op_gt).
  
  Definition compare := (|Included_BASIC_DATA|).(BASIC_DATA.compare).
  
  Definition equal := (|Included_BASIC_DATA|).(BASIC_DATA.equal).
  
  Definition max := (|Included_BASIC_DATA|).(BASIC_DATA.max).
  
  Definition min := (|Included_BASIC_DATA|).(BASIC_DATA.min).
  
  Definition encoding := (|Included_BASIC_DATA|).(BASIC_DATA.encoding).
  
  Definition pp := (|Included_BASIC_DATA|).(BASIC_DATA.pp).
  
  Parameter pp_full : Format.formatter -> t -> unit.
  
  Definition level := t.
  
  Parameter root : context -> level.
  
  Parameter succ : context -> level -> level.
  
  Parameter pred : context -> level -> option level.
  
  Parameter from_raw : context -> option int32 -> Raw_level.t -> level.
  
  Parameter diff : level -> level -> int32.
  
  Parameter current : context -> level.
  
  Parameter last_level_in_cycle : context -> Cycle.t -> level.
  
  Parameter levels_in_cycle : context -> Cycle.t -> list level.
  
  Parameter levels_in_current_cycle :
    context -> option int32 -> unit -> list level.
  
  Parameter last_allowed_fork_level : context -> Raw_level.t.
End Level.

Module Fitness.
  Definition fitness := t.
  
  Parameter increase : option Z -> context -> context.
  
  Parameter current : context -> int64.
  
  Parameter to_int64 : fitness -> Error_monad.tzresult int64.
End Fitness.

Module Nonce.
  Parameter t : Set.
  
  Definition nonce := t.
  
  Parameter encoding : Data_encoding.t nonce.
  
  Module unrevealed.
    Record record := Build {
      nonce_hash : Nonce_hash.t;
      delegate : public_key_hash;
      rewards : Tez.t;
      fees : Tez.t }.
    Definition with_nonce_hash nonce_hash (r : record) :=
      Build nonce_hash r.(delegate) r.(rewards) r.(fees).
    Definition with_delegate delegate (r : record) :=
      Build r.(nonce_hash) delegate r.(rewards) r.(fees).
    Definition with_rewards rewards (r : record) :=
      Build r.(nonce_hash) r.(delegate) rewards r.(fees).
    Definition with_fees fees (r : record) :=
      Build r.(nonce_hash) r.(delegate) r.(rewards) fees.
  End unrevealed.
  Definition unrevealed := unrevealed.record.
  
  Parameter record_hash :
    context -> unrevealed -> Lwt.t (Error_monad.tzresult context).
  
  Parameter reveal :
    context -> Level.t -> nonce -> Lwt.t (Error_monad.tzresult context).
  
  Inductive status : Set :=
  | Unrevealed : unrevealed -> status
  | Revealed : nonce -> status.
  
  Parameter get : context -> Level.t -> Lwt.t (Error_monad.tzresult status).
  
  Parameter of_bytes : MBytes.t -> Error_monad.tzresult nonce.
  
  Parameter __hash_value : nonce -> Nonce_hash.t.
  
  Parameter check_hash : nonce -> Nonce_hash.t -> bool.
End Nonce.

Module Seed.
  Parameter seed : Set.
  
  (* extensible_type error *)
  
  Parameter for_cycle : context -> Cycle.t -> Lwt.t (Error_monad.tzresult seed).
  
  Parameter cycle_end :
    context -> Cycle.t ->
    Lwt.t (Error_monad.tzresult (context * list Nonce.unrevealed)).
  
  Parameter seed_encoding : Data_encoding.t seed.
End Seed.

Module Big_map.
  Definition id := Z.t.
  
  Parameter fresh : context -> Lwt.t (Error_monad.tzresult (context * id)).
  
  Parameter fresh_temporary : context -> context * id.
  
  Parameter mem :
    context -> id -> Script_expr_hash.t ->
    Lwt.t (Error_monad.tzresult (context * bool)).
  
  Parameter get_opt :
    context -> id -> Script_expr_hash.t ->
    Lwt.t (Error_monad.tzresult (context * option Script.expr)).
  
  Parameter rpc_arg : RPC_arg.t id.
  
  Parameter cleanup_temporary : context -> Lwt.t context.
  
  Parameter __exists :
    context -> id ->
    Lwt.t (Error_monad.tzresult (context * option (Script.expr * Script.expr))).
End Big_map.

Module Contract.
  Parameter Included_BASIC_DATA : {t : _ & BASIC_DATA.signature t}.
  
  Definition t := (|Included_BASIC_DATA|).(BASIC_DATA.t).
  
  Definition op_eq := (|Included_BASIC_DATA|).(BASIC_DATA.op_eq).
  
  Definition op_ltgt := (|Included_BASIC_DATA|).(BASIC_DATA.op_ltgt).
  
  Definition op_lt := (|Included_BASIC_DATA|).(BASIC_DATA.op_lt).
  
  Definition op_lteq := (|Included_BASIC_DATA|).(BASIC_DATA.op_lteq).
  
  Definition op_gteq := (|Included_BASIC_DATA|).(BASIC_DATA.op_gteq).
  
  Definition op_gt := (|Included_BASIC_DATA|).(BASIC_DATA.op_gt).
  
  Definition compare := (|Included_BASIC_DATA|).(BASIC_DATA.compare).
  
  Definition equal := (|Included_BASIC_DATA|).(BASIC_DATA.equal).
  
  Definition max := (|Included_BASIC_DATA|).(BASIC_DATA.max).
  
  Definition min := (|Included_BASIC_DATA|).(BASIC_DATA.min).
  
  Definition encoding := (|Included_BASIC_DATA|).(BASIC_DATA.encoding).
  
  Definition pp := (|Included_BASIC_DATA|).(BASIC_DATA.pp).
  
  Definition contract := t.
  
  Parameter rpc_arg : RPC_arg.arg contract.
  
  Parameter to_b58check : contract -> string.
  
  Parameter of_b58check : string -> Error_monad.tzresult contract.
  
  Parameter implicit_contract : public_key_hash -> contract.
  
  Parameter is_implicit : contract -> option public_key_hash.
  
  Parameter __exists : context -> contract -> Lwt.t (Error_monad.tzresult bool).
  
  Parameter must_exist :
    context -> contract -> Lwt.t (Error_monad.tzresult unit).
  
  Parameter allocated :
    context -> contract -> Lwt.t (Error_monad.tzresult bool).
  
  Parameter must_be_allocated :
    context -> contract -> Lwt.t (Error_monad.tzresult unit).
  
  Parameter __list_value : context -> Lwt.t (list contract).
  
  Parameter get_manager_key :
    context -> public_key_hash -> Lwt.t (Error_monad.tzresult public_key).
  
  Parameter is_manager_key_revealed :
    context -> public_key_hash -> Lwt.t (Error_monad.tzresult bool).
  
  Parameter reveal_manager_key :
    context -> public_key_hash -> public_key ->
    Lwt.t (Error_monad.tzresult context).
  
  Parameter get_script_code :
    context -> contract ->
    Lwt.t (Error_monad.tzresult (context * option Script.lazy_expr)).
  
  Parameter get_script :
    context -> contract ->
    Lwt.t (Error_monad.tzresult (context * option Script.t)).
  
  Parameter get_storage :
    context -> contract ->
    Lwt.t (Error_monad.tzresult (context * option Script.expr)).
  
  Parameter get_counter :
    context -> public_key_hash -> Lwt.t (Error_monad.tzresult Z.t).
  
  Parameter get_balance :
    context -> contract -> Lwt.t (Error_monad.tzresult Tez.t).
  
  Parameter init_origination_nonce :
    context -> (|Operation_hash|).(S.HASH.t) -> context.
  
  Parameter unset_origination_nonce : context -> context.
  
  Parameter fresh_contract_from_current_nonce :
    context -> Lwt.t (Error_monad.tzresult (context * t)).
  
  Parameter originated_from_current_nonce :
    context -> context -> Lwt.t (Error_monad.tzresult (list contract)).
  
  Module big_map_diff_item.
    Module Update.
      Record record {big_map diff_key diff_key_hash diff_value : Set} := {
        big_map : big_map;
        diff_key : diff_key;
        diff_key_hash : diff_key_hash;
        diff_value : diff_value }.
      Arguments record : clear implicits.
    End Update.
    Definition Update_skeleton := Update.record.
    
    Module Alloc.
      Record record {big_map key_type value_type : Set} := {
        big_map : big_map;
        key_type : key_type;
        value_type : value_type }.
      Arguments record : clear implicits.
    End Alloc.
    Definition Alloc_skeleton := Alloc.record.
  End big_map_diff_item.
  
  Reserved Notation "'big_map_diff_item.Update".
  Reserved Notation "'big_map_diff_item.Alloc".
  
  Inductive big_map_diff_item : Set :=
  | Update : 'big_map_diff_item.Update -> big_map_diff_item
  | Clear : Big_map.id -> big_map_diff_item
  | Copy : Big_map.id -> Big_map.id -> big_map_diff_item
  | Alloc : 'big_map_diff_item.Alloc -> big_map_diff_item
  
  where "'big_map_diff_item.Update" :=
    (big_map_diff_item.Update_skeleton Big_map.id Script.expr Script_expr_hash.t
      (option Script.expr))
  and "'big_map_diff_item.Alloc" :=
    (big_map_diff_item.Alloc_skeleton Big_map.id Script.expr Script.expr).
  
  Module ConstructorRecordNotations_big_map_diff_item.
    Module big_map_diff_item.
      Definition Update := 'big_map_diff_item.Update.
      Definition Alloc := 'big_map_diff_item.Alloc.
    End big_map_diff_item.
  End ConstructorRecordNotations_big_map_diff_item.
  Import ConstructorRecordNotations_big_map_diff_item.
  
  Definition big_map_diff := list big_map_diff_item.
  
  Parameter big_map_diff_encoding : Data_encoding.t big_map_diff.
  
  Parameter originate :
    context -> contract -> Tez.t -> Script.t * option big_map_diff ->
    option public_key_hash -> Lwt.t (Error_monad.tzresult context).
  
  (* extensible_type error *)
  
  Parameter spend :
    context -> contract -> Tez.t -> Lwt.t (Error_monad.tzresult context).
  
  Parameter credit :
    context -> contract -> Tez.t -> Lwt.t (Error_monad.tzresult context).
  
  Parameter update_script_storage :
    context -> contract -> Script.expr -> option big_map_diff ->
    Lwt.t (Error_monad.tzresult context).
  
  Parameter used_storage_space :
    context -> t -> Lwt.t (Error_monad.tzresult Z.t).
  
  Parameter increment_counter :
    context -> public_key_hash -> Lwt.t (Error_monad.tzresult context).
  
  Parameter check_counter_increment :
    context -> public_key_hash -> Z.t -> Lwt.t (Error_monad.tzresult unit).
  
  Parameter origination_nonce : Set.
  
  Parameter initial_origination_nonce :
    (|Operation_hash|).(S.HASH.t) -> origination_nonce.
  
  Parameter originated_contract : origination_nonce -> contract.
End Contract.

Module Delegate.
  Inductive balance : Set :=
  | Contract : Contract.t -> balance
  | Rewards :
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> Cycle.t -> balance
  | Fees :
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> Cycle.t -> balance
  | Deposits :
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> Cycle.t -> balance.
  
  Inductive balance_update : Set :=
  | Debited : Tez.t -> balance_update
  | Credited : Tez.t -> balance_update.
  
  Definition balance_updates := list (balance * balance_update).
  
  Parameter balance_updates_encoding : Data_encoding.t balance_updates.
  
  Parameter cleanup_balance_updates : balance_updates -> balance_updates.
  
  Parameter get :
    context -> Contract.t ->
    Lwt.t (Error_monad.tzresult (option public_key_hash)).
  
  Parameter set :
    context -> Contract.t -> option public_key_hash ->
    Lwt.t (Error_monad.tzresult context).
  
  Parameter fold : forall {a : Set},
    context -> a -> (public_key_hash -> a -> Lwt.t a) -> Lwt.t a.
  
  Parameter __list_value : context -> Lwt.t (list public_key_hash).
  
  Parameter freeze_deposit :
    context -> public_key_hash -> Tez.t -> Lwt.t (Error_monad.tzresult context).
  
  Parameter freeze_rewards :
    context -> public_key_hash -> Tez.t -> Lwt.t (Error_monad.tzresult context).
  
  Parameter freeze_fees :
    context -> public_key_hash -> Tez.t -> Lwt.t (Error_monad.tzresult context).
  
  Parameter cycle_end :
    context -> Cycle.t -> list Nonce.unrevealed ->
    Lwt.t
      (Error_monad.tzresult
        (context * balance_updates *
          list (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))).
  
  Module frozen_balance.
    Record record := Build {
      deposit : Tez.t;
      fees : Tez.t;
      rewards : Tez.t }.
    Definition with_deposit deposit (r : record) :=
      Build deposit r.(fees) r.(rewards).
    Definition with_fees fees (r : record) :=
      Build r.(deposit) fees r.(rewards).
    Definition with_rewards rewards (r : record) :=
      Build r.(deposit) r.(fees) rewards.
  End frozen_balance.
  Definition frozen_balance := frozen_balance.record.
  
  Parameter punish :
    context -> public_key_hash -> Cycle.t ->
    Lwt.t (Error_monad.tzresult (context * frozen_balance)).
  
  Parameter full_balance :
    context -> public_key_hash -> Lwt.t (Error_monad.tzresult Tez.t).
  
  Parameter has_frozen_balance :
    context -> public_key_hash -> Cycle.t -> Lwt.t (Error_monad.tzresult bool).
  
  Parameter frozen_balance :
    context -> public_key_hash -> Lwt.t (Error_monad.tzresult Tez.t).
  
  Parameter frozen_balance_encoding : Data_encoding.t frozen_balance.
  
  Parameter frozen_balance_by_cycle_encoding :
    Data_encoding.t ((|Cycle.Map|).(S.MAP.t) frozen_balance).
  
  Parameter frozen_balance_by_cycle :
    context -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
    Lwt.t ((|Cycle.Map|).(S.MAP.t) frozen_balance).
  
  Parameter staking_balance :
    context -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
    Lwt.t (Error_monad.tzresult Tez.t).
  
  Parameter delegated_contracts :
    context -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
    Lwt.t (list Contract_repr.t).
  
  Parameter delegated_balance :
    context -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
    Lwt.t (Error_monad.tzresult Tez.t).
  
  Parameter deactivated :
    context -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
    Lwt.t (Error_monad.tzresult bool).
  
  Parameter grace_period :
    context -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
    Lwt.t (Error_monad.tzresult Cycle.t).
End Delegate.

Module Vote.
  Definition proposal := (|Protocol_hash|).(S.HASH.t).
  
  Parameter record_proposal :
    context -> (|Protocol_hash|).(S.HASH.t) -> public_key_hash ->
    Lwt.t (Error_monad.tzresult context).
  
  Parameter get_proposals :
    context ->
    Lwt.t
      (Error_monad.tzresult
        ((|Protocol_hash|).(S.HASH.Map).(S.INDEXES_Map.t) int32)).
  
  Parameter clear_proposals : context -> Lwt.t context.
  
  Parameter recorded_proposal_count_for_delegate :
    context -> public_key_hash -> Lwt.t (Error_monad.tzresult Z).
  
  Parameter listings_encoding :
    Data_encoding.t
      (list ((|Signature.Public_key_hash|).(S.SPublic_key_hash.t) * int32)).
  
  Parameter freeze_listings : context -> Lwt.t (Error_monad.tzresult context).
  
  Parameter clear_listings : context -> Lwt.t (Error_monad.tzresult context).
  
  Parameter listing_size : context -> Lwt.t (Error_monad.tzresult int32).
  
  Parameter in_listings : context -> public_key_hash -> Lwt.t bool.
  
  Parameter get_listings : context -> Lwt.t (list (public_key_hash * int32)).
  
  Inductive ballot : Set :=
  | Yay : ballot
  | Nay : ballot
  | Pass : ballot.
  
  Parameter ballot_encoding : Data_encoding.t ballot.
  
  Module ballots.
    Record record := Build {
      yay : int32;
      nay : int32;
      pass : int32 }.
    Definition with_yay yay (r : record) :=
      Build yay r.(nay) r.(pass).
    Definition with_nay nay (r : record) :=
      Build r.(yay) nay r.(pass).
    Definition with_pass pass (r : record) :=
      Build r.(yay) r.(nay) pass.
  End ballots.
  Definition ballots := ballots.record.
  
  Parameter ballots_encoding : Data_encoding.t ballots.
  
  Parameter has_recorded_ballot : context -> public_key_hash -> Lwt.t bool.
  
  Parameter record_ballot :
    context -> public_key_hash -> ballot -> Lwt.t (Error_monad.tzresult context).
  
  Parameter get_ballots : context -> Lwt.t (Error_monad.tzresult ballots).
  
  Parameter get_ballot_list :
    context ->
    Lwt.t (list ((|Signature.Public_key_hash|).(S.SPublic_key_hash.t) * ballot)).
  
  Parameter clear_ballots : context -> Lwt.t context.
  
  Parameter get_current_period_kind :
    context -> Lwt.t (Error_monad.tzresult Voting_period.kind).
  
  Parameter set_current_period_kind :
    context -> Voting_period.kind -> Lwt.t (Error_monad.tzresult context).
  
  Parameter get_current_quorum : context -> Lwt.t (Error_monad.tzresult int32).
  
  Parameter get_participation_ema :
    context -> Lwt.t (Error_monad.tzresult int32).
  
  Parameter set_participation_ema :
    context -> int32 -> Lwt.t (Error_monad.tzresult context).
  
  Parameter get_current_proposal :
    context -> Lwt.t (Error_monad.tzresult proposal).
  
  Parameter init_current_proposal :
    context -> proposal -> Lwt.t (Error_monad.tzresult context).
  
  Parameter clear_current_proposal :
    context -> Lwt.t (Error_monad.tzresult context).
End Vote.

Module Block_header.
  Module contents.
    Record record {priority seed_nonce_hash proof_of_work_nonce : Set} := Build {
      priority : priority;
      seed_nonce_hash : seed_nonce_hash;
      proof_of_work_nonce : proof_of_work_nonce }.
    Arguments record : clear implicits.
    Definition with_priority
      {t_priority t_seed_nonce_hash t_proof_of_work_nonce} priority
      (r : record t_priority t_seed_nonce_hash t_proof_of_work_nonce) :=
      Build t_priority t_seed_nonce_hash t_proof_of_work_nonce priority
        r.(seed_nonce_hash) r.(proof_of_work_nonce).
    Definition with_seed_nonce_hash
      {t_priority t_seed_nonce_hash t_proof_of_work_nonce} seed_nonce_hash
      (r : record t_priority t_seed_nonce_hash t_proof_of_work_nonce) :=
      Build t_priority t_seed_nonce_hash t_proof_of_work_nonce r.(priority)
        seed_nonce_hash r.(proof_of_work_nonce).
    Definition with_proof_of_work_nonce
      {t_priority t_seed_nonce_hash t_proof_of_work_nonce} proof_of_work_nonce
      (r : record t_priority t_seed_nonce_hash t_proof_of_work_nonce) :=
      Build t_priority t_seed_nonce_hash t_proof_of_work_nonce r.(priority)
        r.(seed_nonce_hash) proof_of_work_nonce.
  End contents.
  Definition contents_skeleton := contents.record.
  
  Module protocol_data.
    Record record {contents signature : Set} := Build {
      contents : contents;
      signature : signature }.
    Arguments record : clear implicits.
    Definition with_contents {t_contents t_signature} contents
      (r : record t_contents t_signature) :=
      Build t_contents t_signature contents r.(signature).
    Definition with_signature {t_contents t_signature} signature
      (r : record t_contents t_signature) :=
      Build t_contents t_signature r.(contents) signature.
  End protocol_data.
  Definition protocol_data_skeleton := protocol_data.record.
  
  Module t.
    Record record {shell protocol_data : Set} := Build {
      shell : shell;
      protocol_data : protocol_data }.
    Arguments record : clear implicits.
    Definition with_shell {t_shell t_protocol_data} shell
      (r : record t_shell t_protocol_data) :=
      Build t_shell t_protocol_data shell r.(protocol_data).
    Definition with_protocol_data {t_shell t_protocol_data} protocol_data
      (r : record t_shell t_protocol_data) :=
      Build t_shell t_protocol_data r.(shell) protocol_data.
  End t.
  Definition t_skeleton := t.record.
  
  Reserved Notation "'t".
  Reserved Notation "'protocol_data".
  Reserved Notation "'contents".
  
  
  
  where "'t" := (t_skeleton Block_header.shell_header 'protocol_data)
  and "'protocol_data" := (protocol_data_skeleton 'contents Signature.t)
  and "'contents" := (contents_skeleton Z (option Nonce_hash.t) MBytes.t).
  
  Definition t := 't.
  Definition protocol_data := 'protocol_data.
  Definition contents := 'contents.
  
  Definition block_header := t.
  
  Definition raw := Block_header.t.
  
  Definition shell_header := Block_header.shell_header.
  
  Parameter __raw_value : block_header -> raw.
  
  Parameter __hash_value : block_header -> (|Block_hash|).(S.HASH.t).
  
  Parameter hash_raw : raw -> (|Block_hash|).(S.HASH.t).
  
  Parameter encoding : Data_encoding.encoding block_header.
  
  Parameter raw_encoding : Data_encoding.t raw.
  
  Parameter contents_encoding : Data_encoding.t contents.
  
  Parameter unsigned_encoding : Data_encoding.t (shell_header * contents).
  
  Parameter protocol_data_encoding : Data_encoding.encoding protocol_data.
  
  Parameter shell_header_encoding : Data_encoding.encoding shell_header.
  
  Parameter max_header_length : Z.
End Block_header.

Module Kind.
  Inductive seed_nonce_revelation : Set :=
  | Seed_nonce_revelation_kind : seed_nonce_revelation.
  
  Inductive double_endorsement_evidence : Set :=
  | Double_endorsement_evidence_kind : double_endorsement_evidence.
  
  Inductive double_baking_evidence : Set :=
  | Double_baking_evidence_kind : double_baking_evidence.
  
  Inductive activate_account : Set :=
  | Activate_account_kind : activate_account.
  
  Inductive endorsement : Set :=
  | Endorsement_kind : endorsement.
  
  Inductive proposals : Set :=
  | Proposals_kind : proposals.
  
  Inductive ballot : Set :=
  | Ballot_kind : ballot.
  
  Inductive reveal : Set :=
  | Reveal_kind : reveal.
  
  Inductive transaction : Set :=
  | Transaction_kind : transaction.
  
  Inductive origination : Set :=
  | Origination_kind : origination.
  
  Inductive delegation : Set :=
  | Delegation_kind : delegation.
  
  Reserved Notation "'manager".
  
  Inductive manager_gadt : Set :=
  | Reveal_manager_kind : manager_gadt
  | Transaction_manager_kind : manager_gadt
  | Origination_manager_kind : manager_gadt
  | Delegation_manager_kind : manager_gadt
  
  where "'manager" := (fun (_ : Set) => manager_gadt).
  
  Definition manager := 'manager.
End Kind.

Module contents.
  Module Endorsement.
    Record record {level : Set} := {
      level : level }.
    Arguments record : clear implicits.
  End Endorsement.
  Definition Endorsement_skeleton := Endorsement.record.
  
  Module Seed_nonce_revelation.
    Record record {level nonce : Set} := {
      level : level;
      nonce : nonce }.
    Arguments record : clear implicits.
  End Seed_nonce_revelation.
  Definition Seed_nonce_revelation_skeleton := Seed_nonce_revelation.record.
  
  Module Double_endorsement_evidence.
    Record record {op1 op2 : Set} := {
      op1 : op1;
      op2 : op2 }.
    Arguments record : clear implicits.
  End Double_endorsement_evidence.
  Definition Double_endorsement_evidence_skeleton :=
    Double_endorsement_evidence.record.
  
  Module Double_baking_evidence.
    Record record {bh1 bh2 : Set} := {
      bh1 : bh1;
      bh2 : bh2 }.
    Arguments record : clear implicits.
  End Double_baking_evidence.
  Definition Double_baking_evidence_skeleton := Double_baking_evidence.record.
  
  Module Activate_account.
    Record record {id activation_code : Set} := {
      id : id;
      activation_code : activation_code }.
    Arguments record : clear implicits.
  End Activate_account.
  Definition Activate_account_skeleton := Activate_account.record.
  
  Module Proposals.
    Record record {source period proposals : Set} := {
      source : source;
      period : period;
      proposals : proposals }.
    Arguments record : clear implicits.
  End Proposals.
  Definition Proposals_skeleton := Proposals.record.
  
  Module Ballot.
    Record record {source period proposal ballot : Set} := {
      source : source;
      period : period;
      proposal : proposal;
      ballot : ballot }.
    Arguments record : clear implicits.
  End Ballot.
  Definition Ballot_skeleton := Ballot.record.
  
  Module Manager_operation.
    Record record {source fee counter operation gas_limit storage_limit : Set} := {
      source : source;
      fee : fee;
      counter : counter;
      operation : operation;
      gas_limit : gas_limit;
      storage_limit : storage_limit }.
    Arguments record : clear implicits.
  End Manager_operation.
  Definition Manager_operation_skeleton := Manager_operation.record.
End contents.

Module manager_operation.
  Module Transaction.
    Record record {amount parameters entrypoint destination : Set} := {
      amount : amount;
      parameters : parameters;
      entrypoint : entrypoint;
      destination : destination }.
    Arguments record : clear implicits.
  End Transaction.
  Definition Transaction_skeleton := Transaction.record.
  
  Module Origination.
    Record record {delegate script credit preorigination : Set} := {
      delegate : delegate;
      script : script;
      credit : credit;
      preorigination : preorigination }.
    Arguments record : clear implicits.
  End Origination.
  Definition Origination_skeleton := Origination.record.
End manager_operation.

Module protocol_data.
  Record record {contents signature : Set} := Build {
    contents : contents;
    signature : signature }.
  Arguments record : clear implicits.
  Definition with_contents {t_contents t_signature} contents
    (r : record t_contents t_signature) :=
    Build t_contents t_signature contents r.(signature).
  Definition with_signature {t_contents t_signature} signature
    (r : record t_contents t_signature) :=
    Build t_contents t_signature r.(contents) signature.
End protocol_data.
Definition protocol_data_skeleton := protocol_data.record.

Module operation.
  Record record {shell protocol_data : Set} := Build {
    shell : shell;
    protocol_data : protocol_data }.
  Arguments record : clear implicits.
  Definition with_shell {t_shell t_protocol_data} shell
    (r : record t_shell t_protocol_data) :=
    Build t_shell t_protocol_data shell r.(protocol_data).
  Definition with_protocol_data {t_shell t_protocol_data} protocol_data
    (r : record t_shell t_protocol_data) :=
    Build t_shell t_protocol_data r.(shell) protocol_data.
End operation.
Definition operation_skeleton := operation.record.

Reserved Notation "'contents.Endorsement".
Reserved Notation "'contents.Seed_nonce_revelation".
Reserved Notation "'contents.Double_endorsement_evidence".
Reserved Notation "'contents.Double_baking_evidence".
Reserved Notation "'contents.Activate_account".
Reserved Notation "'contents.Proposals".
Reserved Notation "'contents.Ballot".
Reserved Notation "'contents.Manager_operation".
Reserved Notation "'manager_operation.Transaction".
Reserved Notation "'manager_operation.Origination".
Reserved Notation "'operation".
Reserved Notation "'protocol_data".
Reserved Notation "'contents_list".
Reserved Notation "'contents".
Reserved Notation "'manager_operation".
Reserved Notation "'counter".

Inductive contents_list_gadt : Set :=
| Single : forall {kind : Set}, 'contents kind -> contents_list_gadt
| Cons : forall {kind : Set},
  'contents (Kind.manager kind) -> contents_list_gadt -> contents_list_gadt

with contents_gadt : Set :=
| Endorsement : 'contents.Endorsement -> contents_gadt
| Seed_nonce_revelation : 'contents.Seed_nonce_revelation -> contents_gadt
| Double_endorsement_evidence :
  'contents.Double_endorsement_evidence -> contents_gadt
| Double_baking_evidence : 'contents.Double_baking_evidence -> contents_gadt
| Activate_account : 'contents.Activate_account -> contents_gadt
| Proposals : 'contents.Proposals -> contents_gadt
| Ballot : 'contents.Ballot -> contents_gadt
| Manager_operation : forall {kind : Set},
  'contents.Manager_operation kind -> contents_gadt

with manager_operation_gadt : Set :=
| Reveal : (|Signature.Public_key|).(S.SPublic_key.t) -> manager_operation_gadt
| Transaction : 'manager_operation.Transaction -> manager_operation_gadt
| Origination : 'manager_operation.Origination -> manager_operation_gadt
| Delegation :
  option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  manager_operation_gadt

where "'operation" := (fun (t_kind : Set) =>
  operation_skeleton Operation.shell_header ('protocol_data t_kind))
and "'protocol_data" := (fun (t_kind : Set) =>
  protocol_data_skeleton ('contents_list t_kind) (option Signature.t))
and "'contents_list" := (fun (_ : Set) => contents_list_gadt)
and "'contents" := (fun (_ : Set) => contents_gadt)
and "'manager_operation" := (fun (_ : Set) => manager_operation_gadt)
and "'counter" := (Z.t)
and "'contents.Endorsement" := (contents.Endorsement_skeleton Raw_level.t)
and "'contents.Seed_nonce_revelation" :=
  (contents.Seed_nonce_revelation_skeleton Raw_level.t Nonce.t)
and "'contents.Double_endorsement_evidence" :=
  (contents.Double_endorsement_evidence_skeleton ('operation Kind.endorsement)
    ('operation Kind.endorsement))
and "'contents.Double_baking_evidence" :=
  (contents.Double_baking_evidence_skeleton Block_header.t Block_header.t)
and "'contents.Activate_account" :=
  (contents.Activate_account_skeleton
    (|Ed25519|).(S.SIGNATURE.Public_key_hash).(S.SPublic_key_hash.t)
    Blinded_public_key_hash.activation_code)
and "'contents.Proposals" :=
  (contents.Proposals_skeleton
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) Voting_period.t
    (list (|Protocol_hash|).(S.HASH.t)))
and "'contents.Ballot" :=
  (contents.Ballot_skeleton (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)
    Voting_period.t (|Protocol_hash|).(S.HASH.t) Vote.ballot)
and "'contents.Manager_operation" := (fun (t_kind : Set) =>
  contents.Manager_operation_skeleton
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) Tez.tez 'counter
    ('manager_operation t_kind) Z.t Z.t)
and "'manager_operation.Transaction" :=
  (manager_operation.Transaction_skeleton Tez.tez Script.lazy_expr string
    Contract.contract)
and "'manager_operation.Origination" :=
  (manager_operation.Origination_skeleton
    (option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) Script.t
    Tez.tez (option Contract.t)).

Module
  ConstructorRecordNotations_contents_list_gadt_contents_gadt_manager_operation_gadt.
  Module contents.
    Definition Endorsement := 'contents.Endorsement.
    Definition Seed_nonce_revelation := 'contents.Seed_nonce_revelation.
    Definition Double_endorsement_evidence :=
      'contents.Double_endorsement_evidence.
    Definition Double_baking_evidence := 'contents.Double_baking_evidence.
    Definition Activate_account := 'contents.Activate_account.
    Definition Proposals := 'contents.Proposals.
    Definition Ballot := 'contents.Ballot.
    Definition Manager_operation := 'contents.Manager_operation.
  End contents.
  Module manager_operation.
    Definition Transaction := 'manager_operation.Transaction.
    Definition Origination := 'manager_operation.Origination.
  End manager_operation.
End
  ConstructorRecordNotations_contents_list_gadt_contents_gadt_manager_operation_gadt.
Import
  ConstructorRecordNotations_contents_list_gadt_contents_gadt_manager_operation_gadt.

Definition operation := 'operation.
Definition protocol_data := 'protocol_data.
Definition contents_list := 'contents_list.
Definition contents := 'contents.
Definition manager_operation := 'manager_operation.
Definition counter := 'counter.

Module internal_operation.
  Record record {kind : Set} := Build {
    source : Contract.contract;
    operation : manager_operation kind;
    nonce : Z }.
  Arguments record : clear implicits.
  Definition with_source {t_kind} source (r : record t_kind) :=
    Build t_kind source r.(operation) r.(nonce).
  Definition with_operation {t_kind} operation (r : record t_kind) :=
    Build t_kind r.(source) operation r.(nonce).
  Definition with_nonce {t_kind} nonce (r : record t_kind) :=
    Build t_kind r.(source) r.(operation) nonce.
End internal_operation.
Definition internal_operation := internal_operation.record.

Reserved Notation "'packed_manager_operation".

Inductive packed_manager_operation_gadt : Set :=
| Manager : forall {kind : Set},
  manager_operation kind -> packed_manager_operation_gadt

where "'packed_manager_operation" := (packed_manager_operation_gadt).

Definition packed_manager_operation := 'packed_manager_operation.

Reserved Notation "'packed_contents".

Inductive packed_contents_gadt : Set :=
| Contents : forall {kind : Set}, contents kind -> packed_contents_gadt

where "'packed_contents" := (packed_contents_gadt).

Definition packed_contents := 'packed_contents.

Reserved Notation "'packed_contents_list".

Inductive packed_contents_list_gadt : Set :=
| Contents_list : forall {kind : Set},
  contents_list kind -> packed_contents_list_gadt

where "'packed_contents_list" := (packed_contents_list_gadt).

Definition packed_contents_list := 'packed_contents_list.

Reserved Notation "'packed_protocol_data".

Inductive packed_protocol_data_gadt : Set :=
| Operation_data : forall {kind : Set},
  protocol_data kind -> packed_protocol_data_gadt

where "'packed_protocol_data" := (packed_protocol_data_gadt).

Definition packed_protocol_data := 'packed_protocol_data.

Module packed_operation.
  Record record := Build {
    shell : Operation.shell_header;
    protocol_data : packed_protocol_data }.
  Definition with_shell shell (r : record) :=
    Build shell r.(protocol_data).
  Definition with_protocol_data protocol_data (r : record) :=
    Build r.(shell) protocol_data.
End packed_operation.
Definition packed_operation := packed_operation.record.

Reserved Notation "'packed_internal_operation".

Inductive packed_internal_operation_gadt : Set :=
| Internal_operation : forall {kind : Set},
  internal_operation kind -> packed_internal_operation_gadt

where "'packed_internal_operation" := (packed_internal_operation_gadt).

Definition packed_internal_operation := 'packed_internal_operation.

Parameter manager_kind : forall {kind : Set},
  manager_operation kind -> Kind.manager kind.

Module Fees.
  Parameter origination_burn :
    context -> Lwt.t (Error_monad.tzresult (context * Tez.t)).
  
  Parameter record_paid_storage_space :
    context -> Contract.t ->
    Lwt.t (Error_monad.tzresult (context * Z.t * Z.t * Tez.t)).
  
  Parameter start_counting_storage_fees : context -> context.
  
  Parameter burn_storage_fees :
    context -> Z.t -> Contract.t -> Lwt.t (Error_monad.tzresult context).
  
  (* extensible_type error *)
  
  (* extensible_type error *)
  
  (* extensible_type error *)
  
  Parameter check_storage_limit : context -> Z.t -> Error_monad.tzresult unit.
End Fees.

Module Operation.
  Definition contents (kind : Set) := contents kind.
  
  Definition packed_contents := packed_contents.
  
  Parameter contents_encoding : Data_encoding.t packed_contents.
  
  Definition protocol_data (kind : Set) := protocol_data kind.
  
  Definition packed_protocol_data := packed_protocol_data.
  
  Parameter protocol_data_encoding : Data_encoding.t packed_protocol_data.
  
  Parameter unsigned_encoding :
    Data_encoding.t (Operation.shell_header * packed_contents_list).
  
  Module raw.
    Record record := Build {
      shell : Operation.shell_header;
      proto : MBytes.t }.
    Definition with_shell shell (r : record) :=
      Build shell r.(proto).
    Definition with_proto proto (r : record) :=
      Build r.(shell) proto.
  End raw.
  Definition raw := raw.record.
  
  Parameter raw_encoding : Data_encoding.t raw.
  
  Parameter contents_list_encoding : Data_encoding.t packed_contents_list.
  
  Module t.
    Record record {kind : Set} := Build {
      shell : Operation.shell_header;
      protocol_data : protocol_data kind }.
    Arguments record : clear implicits.
    Definition with_shell {t_kind} shell (r : record t_kind) :=
      Build t_kind shell r.(protocol_data).
    Definition with_protocol_data {t_kind} protocol_data (r : record t_kind) :=
      Build t_kind r.(shell) protocol_data.
  End t.
  Definition t := t.record.
  
  Definition packed := packed_operation.
  
  Parameter encoding : Data_encoding.t packed.
  
  Parameter __raw_value : forall {A : Set}, operation A -> raw.
  
  Parameter __hash_value : forall {A : Set},
    operation A -> (|Operation_hash|).(S.HASH.t).
  
  Parameter hash_raw : raw -> (|Operation_hash|).(S.HASH.t).
  
  Parameter hash_packed : packed_operation -> (|Operation_hash|).(S.HASH.t).
  
  Parameter acceptable_passes : packed_operation -> list Z.
  
  (* extensible_type error *)
  
  (* extensible_type error *)
  
  Parameter check_signature : forall {A : Set},
    public_key -> (|Chain_id|).(S.HASH.t) -> operation A ->
    Lwt.t (Error_monad.tzresult unit).
  
  Parameter check_signature_sync : forall {A : Set},
    public_key -> (|Chain_id|).(S.HASH.t) -> operation A ->
    Error_monad.tzresult unit.
  
  Parameter internal_operation_encoding :
    Data_encoding.t packed_internal_operation.
  
  Parameter pack : forall {kind : Set}, operation kind -> packed_operation.
  
  Reserved Notation "'eq".
  
  Inductive eq_gadt : Set :=
  | Eq : eq_gadt
  
  where "'eq" := (fun (_ _ : Set) => eq_gadt).
  
  Definition eq := 'eq.
  
  Parameter equal : forall {a b : Set},
    operation a -> operation b -> option (eq a b).
  
  Module Encoding.
    Module case.
      Module Case.
        Record record {tag name encoding select proj inj : Set} := {
          tag : tag;
          name : name;
          encoding : encoding;
          select : select;
          proj : proj;
          inj : inj }.
        Arguments record : clear implicits.
      End Case.
      Definition Case_skeleton := Case.record.
    End case.
    
    Reserved Notation "'case.Case".
    Reserved Notation "'case".
    
    Inductive case_gadt : Set :=
    | Case : forall {a b : Set}, 'case.Case a b -> case_gadt
    
    where "'case" := (fun (_ : Set) => case_gadt)
    and "'case.Case" := (fun (t_a t_b : Set) =>
      case.Case_skeleton Z string (Data_encoding.t t_a)
        (packed_contents -> option (contents t_b)) (contents t_b -> t_a)
        (t_a -> contents t_b)).
    
    Module ConstructorRecordNotations_case_gadt.
      Module case.
        Definition Case := 'case.Case.
      End case.
    End ConstructorRecordNotations_case_gadt.
    Import ConstructorRecordNotations_case_gadt.
    
    Definition case := 'case.
    
    Parameter endorsement_case : case Kind.endorsement.
    
    Parameter seed_nonce_revelation_case : case Kind.seed_nonce_revelation.
    
    Parameter double_endorsement_evidence_case :
      case Kind.double_endorsement_evidence.
    
    Parameter double_baking_evidence_case : case Kind.double_baking_evidence.
    
    Parameter activate_account_case : case Kind.activate_account.
    
    Parameter proposals_case : case Kind.proposals.
    
    Parameter ballot_case : case Kind.ballot.
    
    Parameter reveal_case : case (Kind.manager Kind.reveal).
    
    Parameter transaction_case : case (Kind.manager Kind.transaction).
    
    Parameter origination_case : case (Kind.manager Kind.origination).
    
    Parameter delegation_case : case (Kind.manager Kind.delegation).
    
    Module Manager_operations.
      Module case.
        Module MCase.
          Record record {tag name encoding select proj inj : Set} := {
            tag : tag;
            name : name;
            encoding : encoding;
            select : select;
            proj : proj;
            inj : inj }.
          Arguments record : clear implicits.
        End MCase.
        Definition MCase_skeleton := MCase.record.
      End case.
      
      Reserved Notation "'case.MCase".
      Reserved Notation "'case".
      
      Inductive case_gadt : Set :=
      | MCase : forall {a kind : Set}, 'case.MCase a kind -> case_gadt
      
      where "'case" := (fun (_ : Set) => case_gadt)
      and "'case.MCase" := (fun (t_a t_kind : Set) =>
        case.MCase_skeleton Z string (Data_encoding.t t_a)
          (packed_manager_operation -> option (manager_operation t_kind))
          (manager_operation t_kind -> t_a) (t_a -> manager_operation t_kind)).
      
      Module ConstructorRecordNotations_case_gadt.
        Module case.
          Definition MCase := 'case.MCase.
        End case.
      End ConstructorRecordNotations_case_gadt.
      Import ConstructorRecordNotations_case_gadt.
      
      Definition case := 'case.
      
      Parameter reveal_case : case Kind.reveal.
      
      Parameter transaction_case : case Kind.transaction.
      
      Parameter origination_case : case Kind.origination.
      
      Parameter delegation_case : case Kind.delegation.
    End Manager_operations.
  End Encoding.
  
  Parameter of_list : list packed_contents -> packed_contents_list.
  
  Parameter to_list : packed_contents_list -> list packed_contents.
End Operation.

Module Roll.
  Definition t := int32.
  
  Definition roll := t.
  
  Parameter encoding : Data_encoding.t roll.
  
  Parameter snapshot_rolls : context -> Lwt.t (Error_monad.tzresult context).
  
  Parameter cycle_end :
    context -> Cycle.t -> Lwt.t (Error_monad.tzresult context).
  
  Parameter baking_rights_owner :
    context -> Level.t -> Z -> Lwt.t (Error_monad.tzresult public_key).
  
  Parameter endorsement_rights_owner :
    context -> Level.t -> Z -> Lwt.t (Error_monad.tzresult public_key).
  
  Parameter delegate_pubkey :
    context -> public_key_hash -> Lwt.t (Error_monad.tzresult public_key).
  
  Parameter get_rolls :
    context -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
    Lwt.t (Error_monad.tzresult (list roll)).
  
  Parameter get_change :
    context -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
    Lwt.t (Error_monad.tzresult Tez.t).
End Roll.

Module Commitment.
  Module t.
    Record record := Build {
      blinded_public_key_hash : Blinded_public_key_hash.t;
      amount : Tez.tez }.
    Definition with_blinded_public_key_hash blinded_public_key_hash
      (r : record) :=
      Build blinded_public_key_hash r.(amount).
    Definition with_amount amount (r : record) :=
      Build r.(blinded_public_key_hash) amount.
  End t.
  Definition t := t.record.
  
  Parameter get_opt :
    context -> Blinded_public_key_hash.t ->
    Lwt.t (Error_monad.tzresult (option Tez.t)).
  
  Parameter delete :
    context -> Blinded_public_key_hash.t -> Lwt.t (Error_monad.tzresult context).
End Commitment.

Module Bootstrap.
  Parameter cycle_end :
    context -> Cycle.t -> Lwt.t (Error_monad.tzresult context).
End Bootstrap.

Module Global.
  Parameter get_block_priority : context -> Lwt.t (Error_monad.tzresult Z).
  
  Parameter set_block_priority :
    context -> Z -> Lwt.t (Error_monad.tzresult context).
End Global.

Parameter prepare_first_block :
  Context.t ->
  (context -> Script.t ->
  Lwt.t
    (Error_monad.tzresult ((Script.t * option Contract.big_map_diff) * context)))
  -> Int32.t -> Time.t -> Fitness.t -> Lwt.t (Error_monad.tzresult context).

Parameter prepare :
  Context.t -> Int32.t -> Time.t -> Time.t -> Fitness.t ->
  Lwt.t (Error_monad.tzresult context).

Parameter finalize : option string -> context -> Updater.validation_result.

Parameter activate : context -> (|Protocol_hash|).(S.HASH.t) -> Lwt.t context.

Parameter fork_test_chain :
  context -> (|Protocol_hash|).(S.HASH.t) -> Time.t -> Lwt.t context.

Parameter record_endorsement :
  context -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> context.

Parameter allowed_endorsements :
  context ->
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.t)
    ((|Signature.Public_key|).(S.SPublic_key.t) * list Z * bool).

Parameter init_endorsements :
  context ->
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.t)
    ((|Signature.Public_key|).(S.SPublic_key.t) * list Z * bool) -> context.

Parameter included_endorsements : context -> Z.

Parameter reset_internal_nonce : context -> context.

Parameter fresh_internal_nonce : context -> Error_monad.tzresult (context * Z).

Parameter record_internal_nonce : context -> Z -> context.

Parameter internal_nonce_already_recorded : context -> Z -> bool.

Parameter add_fees : context -> Tez.t -> Lwt.t (Error_monad.tzresult context).

Parameter add_rewards :
  context -> Tez.t -> Lwt.t (Error_monad.tzresult context).

Parameter add_deposit :
  context -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> Tez.t ->
  Lwt.t (Error_monad.tzresult context).

Parameter get_fees : context -> Tez.t.

Parameter get_rewards : context -> Tez.t.

Parameter get_deposits :
  context ->
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.t) Tez.t.

Parameter description : Storage_description.t context.

Alpha_services

  • OCaml size: 117 lines
  • Coq size: 190 lines (+62% compared to OCaml)
alpha_services.ml 34 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

let custom_root = RPC_path.open_root

module Seed = struct
  module S = struct
    open Data_encoding

    let seed =
      RPC_service.post_service
        ~description:"Seed of the cycle to which the block belongs."
        ~query:RPC_query.empty
        ~input:empty
        ~output:Seed.seed_encoding
        RPC_path.(custom_root / "context" / "seed")
  end

  let () =
    let open Services_registration in
    register0 S.seed (fun ctxt () () ->
        let l = Level.current ctxt in
        Seed.for_cycle ctxt l.cycle)

  let get ctxt block = RPC_context.make_call0 S.seed ctxt block () ()
end

module Nonce = struct
  type info = Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten

  let info_encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Revealed"
          (obj1 (req "nonce" Nonce.encoding))
          (function Revealed nonce -> Some nonce | _ -> None)
          (fun nonce -> Revealed nonce);
        case
          (Tag 1)
          ~title:"Missing"
          (obj1 (req "hash" Nonce_hash.encoding))
          (function Missing nonce -> Some nonce | _ -> None)
          (fun nonce -> Missing nonce);
        case
          (Tag 2)
          ~title:"Forgotten"
          empty
          (function Forgotten -> Some () | _ -> None)
          (fun () -> Forgotten) ]

  module S = struct
    let get =
      RPC_service.get_service
        ~description:"Info about the nonce of a previous block."
        ~query:RPC_query.empty
        ~output:info_encoding
        RPC_path.(custom_root / "context" / "nonces" /: Raw_level.rpc_arg)
  end

  let register () =
    let open Services_registration in
    register1 S.get (fun ctxt raw_level () () ->
        let level = Level.from_raw ctxt raw_level in
        Nonce.get ctxt level
        >>= function
        | Ok (Revealed nonce) ->
            return (Revealed nonce)
        | Ok (Unrevealed {nonce_hash; _}) ->
            return (Missing nonce_hash)
        | Error _ ->
            return Forgotten)

  let get ctxt block level =
    RPC_context.make_call1 S.get ctxt block level () ()
end

module Contract = Contract_services
module Constants = Constants_services
module Delegate = Delegate_services
module Helpers = Helpers_services
module Forge = Helpers_services.Forge
module Parse = Helpers_services.Parse
module Voting = Voting_services

let register () =
  Contract.register () ;
  Constants.register () ;
  Delegate.register () ;
  Helpers.register () ;
  Nonce.register () ;
  Voting.register ()
Alpha_services.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Nonce_hash.
Require Tezos.Services_registration.

Import Alpha_context.

Definition custom_root {A : Set} : RPC_path.context A := RPC_path.open_root.

Module Seed.
  Module S.
    Import Data_encoding.
    
    Definition __seed_value
      : RPC_service.service (* `POST *) unit Updater.rpc_context
        Updater.rpc_context unit unit Alpha_context.Seed.seed :=
      RPC_service.post_service
        (Some "Seed of the cycle to which the block belongs.") RPC_query.empty
        Data_encoding.empty Alpha_context.Seed.seed_encoding
        (RPC_path.op_div (RPC_path.op_div custom_root "context") "seed").
  End S.
  
  (* ❌ Top-level evaluations are not handled *)
  (* top_level_evaluation *)
  
  Definition get {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    : Lwt.t (Error_monad.shell_tzresult Alpha_context.Seed.seed) :=
    RPC_context.make_call0 S.__seed_value ctxt block tt tt.
End Seed.

Module Nonce.
  Inductive info : Set :=
  | Revealed : Alpha_context.Nonce.t -> info
  | Missing : Nonce_hash.t -> info
  | Forgotten : info.
  
  Definition info_encoding : Data_encoding.encoding info :=
    Data_encoding.union None
      [
        Data_encoding.__case_value "Revealed" None (Data_encoding.Tag 0)
          (Data_encoding.obj1
            (Data_encoding.req None None "nonce"
              Alpha_context.Nonce.encoding))
          (fun function_parameter =>
            match function_parameter with
            | Revealed __nonce_value => Some __nonce_value
            | _ => None
            end) (fun __nonce_value => Revealed __nonce_value);
        Data_encoding.__case_value "Missing" None (Data_encoding.Tag 1)
          (Data_encoding.obj1
            (Data_encoding.req None None "hash" Nonce_hash.encoding))
          (fun function_parameter =>
            match function_parameter with
            | Missing __nonce_value => Some __nonce_value
            | _ => None
            end) (fun __nonce_value => Missing __nonce_value);
        Data_encoding.__case_value "Forgotten" None (Data_encoding.Tag 2)
          Data_encoding.empty
          (fun function_parameter =>
            match function_parameter with
            | Forgotten => Some tt
            | _ => None
            end)
          (fun function_parameter =>
            let '_ := function_parameter in
            Forgotten)
      ].
  
  Module S.
    Definition get
      : RPC_service.service (* `GET *) unit Updater.rpc_context
        (Updater.rpc_context * Alpha_context.Raw_level.raw_level) unit unit info :=
      RPC_service.get_service (Some "Info about the nonce of a previous block.")
        RPC_query.empty info_encoding
        (RPC_path.op_divcolon
          (RPC_path.op_div (RPC_path.op_div custom_root "context") "nonces")
          Alpha_context.Raw_level.rpc_arg).
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    let '_ := function_parameter in
    Services_registration.register1 S.get
      (fun ctxt =>
        fun raw_level =>
          fun function_parameter =>
            let '_ := function_parameter in
            fun function_parameter =>
              let '_ := function_parameter in
              let level := Alpha_context.Level.from_raw ctxt None raw_level in
              Error_monad.op_gtgteq (Alpha_context.Nonce.get ctxt level)
                (fun function_parameter =>
                  match function_parameter with
                  | Pervasives.Ok (Alpha_context.Nonce.Revealed __nonce_value)
                    => Error_monad.__return (Revealed __nonce_value)
                  |
                    Pervasives.Ok
                      (Alpha_context.Nonce.Unrevealed {|
                        Alpha_context.Nonce.unrevealed.nonce_hash := nonce_hash
                          |}) => Error_monad.__return (Missing nonce_hash)
                  | Pervasives.Error _ => Error_monad.__return Forgotten
                  end)).
  
  Definition get {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    (level : Alpha_context.Raw_level.raw_level)
    : Lwt.t (Error_monad.shell_tzresult info) :=
    RPC_context.make_call1 S.get ctxt block level tt tt.
End Nonce.

Module Contract := Contract_services.

Module Constants := Constants_services.

Module Delegate := Delegate_services.

Module Helpers := Helpers_services.

Module Forge := Helpers_services.Forge.

Module Parse := Helpers_services.Parse.

Module Voting := Voting_services.

Definition register (function_parameter : unit) : unit :=
  let '_ := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  Voting.register tt.

Alpha_services_mli

  • OCaml size: 47 lines
  • Coq size: 85 lines (+80% compared to OCaml)
alpha_services.mli 33 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

module Seed : sig
  val get : 'a #RPC_context.simple -> 'a -> Seed.seed shell_tzresult Lwt.t
end

module Nonce : sig
  type info = Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten

  val get :
    'a #RPC_context.simple -> 'a -> Raw_level.t -> info shell_tzresult Lwt.t
end

module Contract = Contract_services
module Constants = Constants_services
module Delegate = Delegate_services
module Helpers = Helpers_services
module Forge = Helpers_services.Forge
module Parse = Helpers_services.Parse
module Voting = Voting_services

val register : unit -> unit
Alpha_services_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Nonce_hash.

Module Seed.
  Parameter get : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    Lwt.t (Error_monad.shell_tzresult Alpha_context.Seed.seed).
End Seed.

Module Nonce.
  Inductive info : Set :=
  | Revealed : Alpha_context.Nonce.t -> info
  | Missing : Nonce_hash.t -> info
  | Forgotten : info.
  
  Parameter get : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    Alpha_context.Raw_level.t -> Lwt.t (Error_monad.shell_tzresult info).
End Nonce.

Parameter Contract : alias.

Parameter Constants : alias.

Parameter Delegate : alias.

Parameter Helpers : alias.

Parameter Forge : alias.

Parameter Parse : alias.

Parameter Voting : alias.

Parameter register : unit -> unit.

Amendment

  • OCaml size: 323 lines
  • Coq size: 339 lines (+4% compared to OCaml)
amendment.ml 11 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

(** Returns the proposal submitted by the most delegates.
    Returns None in case of a tie, if proposal quorum is below required
    minimum or if there are no proposals. *)
let select_winning_proposal ctxt =
  Vote.get_proposals ctxt
  >>=? fun proposals ->
  let merge proposal vote winners =
    match winners with
    | None ->
        Some ([proposal], vote)
    | Some (winners, winners_vote) as previous ->
        if Compare.Int32.(vote = winners_vote) then
          Some (proposal :: winners, winners_vote)
        else if Compare.Int32.(vote > winners_vote) then Some ([proposal], vote)
        else previous
  in
  match Protocol_hash.Map.fold merge proposals None with
  | Some ([proposal], vote) ->
      Vote.listing_size ctxt
      >>=? fun max_vote ->
      let min_proposal_quorum = Constants.min_proposal_quorum ctxt in
      let min_vote_to_pass =
        Int32.div (Int32.mul min_proposal_quorum max_vote) 100_00l
      in
      if Compare.Int32.(vote >= min_vote_to_pass) then return_some proposal
      else return_none
  | _ ->
      return_none

(* in case of a tie, let's do nothing. *)

(** A proposal is approved if it has supermajority and the participation reaches
    the current quorum.
    Supermajority means the yays are more 8/10 of casted votes.
    The participation is the ratio of all received votes, including passes, with
    respect to the number of possible votes.
    The participation EMA (exponential moving average) uses the last
    participation EMA and the current participation./
    The expected quorum is calculated using the last participation EMA, capped
    by the min/max quorum protocol constants. *)
let check_approval_and_update_participation_ema ctxt =
  Vote.get_ballots ctxt
  >>=? fun ballots ->
  Vote.listing_size ctxt
  >>=? fun maximum_vote ->
  Vote.get_participation_ema ctxt
  >>=? fun participation_ema ->
  Vote.get_current_quorum ctxt
  >>=? fun expected_quorum ->
  (* Note overflows: considering a maximum of 8e8 tokens, with roll size as
     small as 1e3, there is a maximum of 8e5 rolls and thus votes.
     In 'participation' an Int64 is used because in the worst case 'all_votes is
     8e5 and after the multiplication is 8e9, making it potentially overflow a
     signed Int32 which is 2e9. *)
  let casted_votes = Int32.add ballots.yay ballots.nay in
  let all_votes = Int32.add casted_votes ballots.pass in
  let supermajority = Int32.div (Int32.mul 8l casted_votes) 10l in
  let participation =
    (* in centile of percentage *)
    Int64.(
      to_int32 (div (mul (of_int32 all_votes) 100_00L) (of_int32 maximum_vote)))
  in
  let outcome =
    Compare.Int32.(
      participation >= expected_quorum && ballots.yay >= supermajority)
  in
  let new_participation_ema =
    Int32.(div (add (mul 8l participation_ema) (mul 2l participation)) 10l)
  in
  Vote.set_participation_ema ctxt new_participation_ema
  >>=? fun ctxt -> return (ctxt, outcome)

(** Implements the state machine of the amendment procedure.
    Note that [freeze_listings], that computes the vote weight of each delegate,
    is run at the beginning of each voting period.
*)
let start_new_voting_period ctxt =
  Vote.get_current_period_kind ctxt
  >>=? function
  | Proposal -> (
      select_winning_proposal ctxt
      >>=? fun proposal ->
      Vote.clear_proposals ctxt
      >>= fun ctxt ->
      Vote.clear_listings ctxt
      >>=? fun ctxt ->
      match proposal with
      | None ->
          Vote.freeze_listings ctxt >>=? fun ctxt -> return ctxt
      | Some proposal ->
          Vote.init_current_proposal ctxt proposal
          >>=? fun ctxt ->
          Vote.freeze_listings ctxt
          >>=? fun ctxt ->
          Vote.set_current_period_kind ctxt Testing_vote
          >>=? fun ctxt -> return ctxt )
  | Testing_vote ->
      check_approval_and_update_participation_ema ctxt
      >>=? fun (ctxt, approved) ->
      Vote.clear_ballots ctxt
      >>= fun ctxt ->
      Vote.clear_listings ctxt
      >>=? fun ctxt ->
      if approved then
        let expiration =
          (* in two days maximum... *)
          Time.add
            (Timestamp.current ctxt)
            (Constants.test_chain_duration ctxt)
        in
        Vote.get_current_proposal ctxt
        >>=? fun proposal ->
        fork_test_chain ctxt proposal expiration
        >>= fun ctxt ->
        Vote.set_current_period_kind ctxt Testing >>=? fun ctxt -> return ctxt
      else
        Vote.clear_current_proposal ctxt
        >>=? fun ctxt ->
        Vote.freeze_listings ctxt
        >>=? fun ctxt ->
        Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> return ctxt
  | Testing ->
      Vote.freeze_listings ctxt
      >>=? fun ctxt ->
      Vote.set_current_period_kind ctxt Promotion_vote
      >>=? fun ctxt -> return ctxt
  | Promotion_vote ->
      check_approval_and_update_participation_ema ctxt
      >>=? fun (ctxt, approved) ->
      ( if approved then
        Vote.get_current_proposal ctxt
        >>=? fun proposal -> activate ctxt proposal >>= fun ctxt -> return ctxt
      else return ctxt )
      >>=? fun ctxt ->
      Vote.clear_ballots ctxt
      >>= fun ctxt ->
      Vote.clear_listings ctxt
      >>=? fun ctxt ->
      Vote.clear_current_proposal ctxt
      >>=? fun ctxt ->
      Vote.freeze_listings ctxt
      >>=? fun ctxt ->
      Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> return ctxt

type error +=
  | (* `Branch *)
      Invalid_proposal
  | Unexpected_proposal
  | Unauthorized_proposal
  | Too_many_proposals
  | Empty_proposal
  | Unexpected_ballot
  | Unauthorized_ballot

let () =
  let open Data_encoding in
  (* Invalid proposal *)
  register_error_kind
    `Branch
    ~id:"invalid_proposal"
    ~title:"Invalid proposal"
    ~description:"Ballot provided for a proposal that is not the current one."
    ~pp:(fun ppf () -> Format.fprintf ppf "Invalid proposal")
    empty
    (function Invalid_proposal -> Some () | _ -> None)
    (fun () -> Invalid_proposal) ;
  (* Unexpected proposal *)
  register_error_kind
    `Branch
    ~id:"unexpected_proposal"
    ~title:"Unexpected proposal"
    ~description:"Proposal recorded outside of a proposal period."
    ~pp:(fun ppf () -> Format.fprintf ppf "Unexpected proposal")
    empty
    (function Unexpected_proposal -> Some () | _ -> None)
    (fun () -> Unexpected_proposal) ;
  (* Unauthorized proposal *)
  register_error_kind
    `Branch
    ~id:"unauthorized_proposal"
    ~title:"Unauthorized proposal"
    ~description:
      "The delegate provided for the proposal is not in the voting listings."
    ~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized proposal")
    empty
    (function Unauthorized_proposal -> Some () | _ -> None)
    (fun () -> Unauthorized_proposal) ;
  (* Unexpected ballot *)
  register_error_kind
    `Branch
    ~id:"unexpected_ballot"
    ~title:"Unexpected ballot"
    ~description:"Ballot recorded outside of a voting period."
    ~pp:(fun ppf () -> Format.fprintf ppf "Unexpected ballot")
    empty
    (function Unexpected_ballot -> Some () | _ -> None)
    (fun () -> Unexpected_ballot) ;
  (* Unauthorized ballot *)
  register_error_kind
    `Branch
    ~id:"unauthorized_ballot"
    ~title:"Unauthorized ballot"
    ~description:
      "The delegate provided for the ballot is not in the voting listings."
    ~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized ballot")
    empty
    (function Unauthorized_ballot -> Some () | _ -> None)
    (fun () -> Unauthorized_ballot) ;
  (* Too many proposals *)
  register_error_kind
    `Branch
    ~id:"too_many_proposals"
    ~title:"Too many proposals"
    ~description:
      "The delegate reached the maximum number of allowed proposals."
    ~pp:(fun ppf () -> Format.fprintf ppf "Too many proposals")
    empty
    (function Too_many_proposals -> Some () | _ -> None)
    (fun () -> Too_many_proposals) ;
  (* Empty proposal *)
  register_error_kind
    `Branch
    ~id:"empty_proposal"
    ~title:"Empty proposal"
    ~description:"Proposal lists cannot be empty."
    ~pp:(fun ppf () -> Format.fprintf ppf "Empty proposal")
    empty
    (function Empty_proposal -> Some () | _ -> None)
    (fun () -> Empty_proposal)

(* @return [true] if [List.length l] > [n] w/o computing length *)
let rec longer_than l n =
  if Compare.Int.(n < 0) then assert false
  else
    match l with
    | [] ->
        false
    | _ :: rest ->
        if Compare.Int.(n = 0) then true
        else (* n > 0 *)
          longer_than rest (n - 1)

let record_proposals ctxt delegate proposals =
  (match proposals with [] -> fail Empty_proposal | _ :: _ -> return_unit)
  >>=? fun () ->
  Vote.get_current_period_kind ctxt
  >>=? function
  | Proposal ->
      Vote.in_listings ctxt delegate
      >>= fun in_listings ->
      if in_listings then
        Vote.recorded_proposal_count_for_delegate ctxt delegate
        >>=? fun count ->
        fail_when
          (longer_than proposals (Constants.max_proposals_per_delegate - count))
          Too_many_proposals
        >>=? fun () ->
        fold_left_s
          (fun ctxt proposal -> Vote.record_proposal ctxt proposal delegate)
          ctxt
          proposals
        >>=? fun ctxt -> return ctxt
      else fail Unauthorized_proposal
  | Testing_vote | Testing | Promotion_vote ->
      fail Unexpected_proposal

let record_ballot ctxt delegate proposal ballot =
  Vote.get_current_period_kind ctxt
  >>=? function
  | Testing_vote | Promotion_vote ->
      Vote.get_current_proposal ctxt
      >>=? fun current_proposal ->
      fail_unless
        (Protocol_hash.equal proposal current_proposal)
        Invalid_proposal
      >>=? fun () ->
      Vote.has_recorded_ballot ctxt delegate
      >>= fun has_ballot ->
      fail_when has_ballot Unauthorized_ballot
      >>=? fun () ->
      Vote.in_listings ctxt delegate
      >>= fun in_listings ->
      if in_listings then Vote.record_ballot ctxt delegate ballot
      else fail Unauthorized_ballot
  | Testing | Proposal ->
      fail Unexpected_ballot

let last_of_a_voting_period ctxt l =
  Compare.Int32.(
    Int32.succ l.Level.voting_period_position
    = Constants.blocks_per_voting_period ctxt)

let may_start_new_voting_period ctxt =
  let level = Level.current ctxt in
  if last_of_a_voting_period ctxt level then start_new_voting_period ctxt
  else return ctxt
Amendment.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.

Import Alpha_context.

Definition select_winning_proposal (ctxt : Alpha_context.context)
  : Lwt.t
    (Error_monad.tzresult
      (option (|Protocol_hash|).(S.HASH.Map).(S.INDEXES_Map.key))) :=
  Error_monad.op_gtgteqquestion (Alpha_context.Vote.get_proposals ctxt)
    (fun proposals =>
      let merge {A : Set}
        (proposal : A) (vote : (|Compare.Int32|).(Compare.S.t))
        (winners : option (list A * (|Compare.Int32|).(Compare.S.t)))
        : option (list A * (|Compare.Int32|).(Compare.S.t)) :=
        match winners with
        | None => Some ([ proposal ], vote)
        | (Some (winners, winners_vote)) as previous =>
          if (|Compare.Int32|).(Compare.S.op_eq) vote winners_vote then
            Some ((cons proposal winners), winners_vote)
          else
            if (|Compare.Int32|).(Compare.S.op_gt) vote winners_vote then
              Some ([ proposal ], vote)
            else
              previous
        end in
      match
        (|Protocol_hash|).(S.HASH.Map).(S.INDEXES_Map.fold) merge proposals None
        with
      | Some (cons proposal [], vote) =>
        Error_monad.op_gtgteqquestion (Alpha_context.Vote.listing_size ctxt)
          (fun max_vote =>
            let min_proposal_quorum :=
              Alpha_context.Constants.min_proposal_quorum ctxt in
            let min_vote_to_pass :=
              Int32.div (Int32.mul min_proposal_quorum max_vote)
                (* ❌ Constant of type int32 is converted to int *)
                10000 in
            if (|Compare.Int32|).(Compare.S.op_gteq) vote min_vote_to_pass then
              Error_monad.return_some proposal
            else
              Error_monad.return_none)
      | _ => Error_monad.return_none
      end).

Definition check_approval_and_update_participation_ema
  (ctxt : Alpha_context.context)
  : Lwt.t (Error_monad.tzresult (Alpha_context.context * bool)) :=
  Error_monad.op_gtgteqquestion (Alpha_context.Vote.get_ballots ctxt)
    (fun ballots =>
      Error_monad.op_gtgteqquestion (Alpha_context.Vote.listing_size ctxt)
        (fun maximum_vote =>
          Error_monad.op_gtgteqquestion
            (Alpha_context.Vote.get_participation_ema ctxt)
            (fun participation_ema =>
              Error_monad.op_gtgteqquestion
                (Alpha_context.Vote.get_current_quorum ctxt)
                (fun expected_quorum =>
                  let casted_votes :=
                    Int32.add (Alpha_context.Vote.ballots.yay ballots)
                      (Alpha_context.Vote.ballots.nay ballots) in
                  let all_votes :=
                    Int32.add casted_votes
                      (Alpha_context.Vote.ballots.pass ballots) in
                  let supermajority :=
                    Int32.div
                      (Int32.mul
                        (* ❌ Constant of type int32 is converted to int *)
                        8 casted_votes)
                      (* ❌ Constant of type int32 is converted to int *)
                      10 in
                  let participation :=
                    Int64.to_int32
                      (Int64.div
                        (Int64.mul (Int64.of_int32 all_votes)
                          (* ❌ Constant of type int64 is converted to int *)
                          10000) (Int64.of_int32 maximum_vote)) in
                  let outcome :=
                    Pervasives.op_andand
                      ((|Compare.Int32|).(Compare.S.op_gteq) participation
                        expected_quorum)
                      ((|Compare.Int32|).(Compare.S.op_gteq)
                        (Alpha_context.Vote.ballots.yay ballots) supermajority)
                    in
                  let new_participation_ema :=
                    Int32.div
                      (Int32.add
                        (Int32.mul
                          (* ❌ Constant of type int32 is converted to int *)
                          8 participation_ema)
                        (Int32.mul
                          (* ❌ Constant of type int32 is converted to int *)
                          2 participation))
                      (* ❌ Constant of type int32 is converted to int *)
                      10 in
                  Error_monad.op_gtgteqquestion
                    (Alpha_context.Vote.set_participation_ema ctxt
                      new_participation_ema)
                    (fun ctxt => Error_monad.__return (ctxt, outcome)))))).

Definition start_new_voting_period (ctxt : Alpha_context.context)
  : Lwt.t (Error_monad.tzresult Alpha_context.context) :=
  Error_monad.op_gtgteqquestion
    (Alpha_context.Vote.get_current_period_kind ctxt)
    (fun function_parameter =>
      match function_parameter with
      | Alpha_context.Voting_period.Proposal =>
        Error_monad.op_gtgteqquestion (select_winning_proposal ctxt)
          (fun proposal =>
            Error_monad.op_gtgteq (Alpha_context.Vote.clear_proposals ctxt)
              (fun ctxt =>
                Error_monad.op_gtgteqquestion
                  (Alpha_context.Vote.clear_listings ctxt)
                  (fun ctxt =>
                    match proposal with
                    | None =>
                      Error_monad.op_gtgteqquestion
                        (Alpha_context.Vote.freeze_listings ctxt)
                        (fun ctxt => Error_monad.__return ctxt)
                    | Some proposal =>
                      Error_monad.op_gtgteqquestion
                        (Alpha_context.Vote.init_current_proposal ctxt proposal)
                        (fun ctxt =>
                          Error_monad.op_gtgteqquestion
                            (Alpha_context.Vote.freeze_listings ctxt)
                            (fun ctxt =>
                              Error_monad.op_gtgteqquestion
                                (Alpha_context.Vote.set_current_period_kind ctxt
                                  Alpha_context.Voting_period.Testing_vote)
                                (fun ctxt => Error_monad.__return ctxt)))
                    end)))
      | Alpha_context.Voting_period.Testing_vote =>
        Error_monad.op_gtgteqquestion
          (check_approval_and_update_participation_ema ctxt)
          (fun function_parameter =>
            let '(ctxt, approved) := function_parameter in
            Error_monad.op_gtgteq (Alpha_context.Vote.clear_ballots ctxt)
              (fun ctxt =>
                Error_monad.op_gtgteqquestion
                  (Alpha_context.Vote.clear_listings ctxt)
                  (fun ctxt =>
                    if approved then
                      let expiration :=
                        Time.add (Alpha_context.Timestamp.current ctxt)
                          (Alpha_context.Constants.test_chain_duration ctxt) in
                      Error_monad.op_gtgteqquestion
                        (Alpha_context.Vote.get_current_proposal ctxt)
                        (fun proposal =>
                          Error_monad.op_gtgteq
                            (Alpha_context.fork_test_chain ctxt proposal
                              expiration)
                            (fun ctxt =>
                              Error_monad.op_gtgteqquestion
                                (Alpha_context.Vote.set_current_period_kind ctxt
                                  Alpha_context.Voting_period.Testing)
                                (fun ctxt => Error_monad.__return ctxt)))
                    else
                      Error_monad.op_gtgteqquestion
                        (Alpha_context.Vote.clear_current_proposal ctxt)
                        (fun ctxt =>
                          Error_monad.op_gtgteqquestion
                            (Alpha_context.Vote.freeze_listings ctxt)
                            (fun ctxt =>
                              Error_monad.op_gtgteqquestion
                                (Alpha_context.Vote.set_current_period_kind ctxt
                                  Alpha_context.Voting_period.Proposal)
                                (fun ctxt => Error_monad.__return ctxt))))))
      | Alpha_context.Voting_period.Testing =>
        Error_monad.op_gtgteqquestion (Alpha_context.Vote.freeze_listings ctxt)
          (fun ctxt =>
            Error_monad.op_gtgteqquestion
              (Alpha_context.Vote.set_current_period_kind ctxt
                Alpha_context.Voting_period.Promotion_vote)
              (fun ctxt => Error_monad.__return ctxt))
      | Alpha_context.Voting_period.Promotion_vote =>
        Error_monad.op_gtgteqquestion
          (check_approval_and_update_participation_ema ctxt)
          (fun function_parameter =>
            let '(ctxt, approved) := function_parameter in
            Error_monad.op_gtgteqquestion
              (if approved then
                Error_monad.op_gtgteqquestion
                  (Alpha_context.Vote.get_current_proposal ctxt)
                  (fun proposal =>
                    Error_monad.op_gtgteq (Alpha_context.activate ctxt proposal)
                      (fun ctxt => Error_monad.__return ctxt))
              else
                Error_monad.__return ctxt)
              (fun ctxt =>
                Error_monad.op_gtgteq (Alpha_context.Vote.clear_ballots ctxt)
                  (fun ctxt =>
                    Error_monad.op_gtgteqquestion
                      (Alpha_context.Vote.clear_listings ctxt)
                      (fun ctxt =>
                        Error_monad.op_gtgteqquestion
                          (Alpha_context.Vote.clear_current_proposal ctxt)
                          (fun ctxt =>
                            Error_monad.op_gtgteqquestion
                              (Alpha_context.Vote.freeze_listings ctxt)
                              (fun ctxt =>
                                Error_monad.op_gtgteqquestion
                                  (Alpha_context.Vote.set_current_period_kind
                                    ctxt Alpha_context.Voting_period.Proposal)
                                  (fun ctxt => Error_monad.__return ctxt)))))))
      end).

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Fixpoint longer_than {A : Set} (l : list A) (n : (|Compare.Int|).(Compare.S.t))
  {struct l} : bool :=
  if (|Compare.Int|).(Compare.S.op_lt) n 0 then
    (* ❌ Assert instruction is not handled. *)
    assert false
  else
    match l with
    | [] => false
    | cons _ rest =>
      if (|Compare.Int|).(Compare.S.op_eq) n 0 then
        true
      else
        longer_than rest (Pervasives.op_minus n 1)
    end.

Definition record_proposals
  (ctxt : Alpha_context.context) (delegate : Alpha_context.public_key_hash)
  (proposals : list (|Protocol_hash|).(S.HASH.t))
  : Lwt.t (Error_monad.tzresult Alpha_context.context) :=
  Error_monad.op_gtgteqquestion
    match proposals with
    | [] => Error_monad.fail extensible_type_value
    | cons _ _ => Error_monad.return_unit
    end
    (fun function_parameter =>
      let '_ := function_parameter in
      Error_monad.op_gtgteqquestion
        (Alpha_context.Vote.get_current_period_kind ctxt)
        (fun function_parameter =>
          match function_parameter with
          | Alpha_context.Voting_period.Proposal =>
            Error_monad.op_gtgteq (Alpha_context.Vote.in_listings ctxt delegate)
              (fun in_listings =>
                if in_listings then
                  Error_monad.op_gtgteqquestion
                    (Alpha_context.Vote.recorded_proposal_count_for_delegate
                      ctxt delegate)
                    (fun count =>
                      Error_monad.op_gtgteqquestion
                        (Error_monad.fail_when
                          (longer_than proposals
                            (Pervasives.op_minus
                              Alpha_context.Constants.max_proposals_per_delegate
                              count)) extensible_type_value)
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          Error_monad.op_gtgteqquestion
                            (Error_monad.fold_left_s
                              (fun ctxt =>
                                fun proposal =>
                                  Alpha_context.Vote.record_proposal ctxt
                                    proposal delegate) ctxt proposals)
                            (fun ctxt => Error_monad.__return ctxt)))
                else
                  Error_monad.fail extensible_type_value)
          |
            Alpha_context.Voting_period.Testing_vote |
            Alpha_context.Voting_period.Testing |
            Alpha_context.Voting_period.Promotion_vote =>
            Error_monad.fail extensible_type_value
          end)).

Definition record_ballot
  (ctxt : Alpha_context.context) (delegate : Alpha_context.public_key_hash)
  (proposal : (|Protocol_hash|).(S.HASH.t)) (ballot : Alpha_context.Vote.ballot)
  : Lwt.t (Error_monad.tzresult Alpha_context.context) :=
  Error_monad.op_gtgteqquestion
    (Alpha_context.Vote.get_current_period_kind ctxt)
    (fun function_parameter =>
      match function_parameter with
      |
        Alpha_context.Voting_period.Testing_vote |
        Alpha_context.Voting_period.Promotion_vote =>
        Error_monad.op_gtgteqquestion
          (Alpha_context.Vote.get_current_proposal ctxt)
          (fun current_proposal =>
            Error_monad.op_gtgteqquestion
              (Error_monad.fail_unless
                ((|Protocol_hash|).(S.HASH.equal) proposal current_proposal)
                extensible_type_value)
              (fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.op_gtgteq
                  (Alpha_context.Vote.has_recorded_ballot ctxt delegate)
                  (fun has_ballot =>
                    Error_monad.op_gtgteqquestion
                      (Error_monad.fail_when has_ballot extensible_type_value)
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        Error_monad.op_gtgteq
                          (Alpha_context.Vote.in_listings ctxt delegate)
                          (fun in_listings =>
                            if in_listings then
                              Alpha_context.Vote.record_ballot ctxt delegate
                                ballot
                            else
                              Error_monad.fail extensible_type_value)))))
      |
        Alpha_context.Voting_period.Testing |
        Alpha_context.Voting_period.Proposal =>
        Error_monad.fail extensible_type_value
      end).

Definition last_of_a_voting_period
  (ctxt : Alpha_context.context) (l : Alpha_context.Level.t) : bool :=
  (|Compare.Int32|).(Compare.S.op_eq)
    (Int32.succ (Alpha_context.Level.t.voting_period_position l))
    (Alpha_context.Constants.blocks_per_voting_period ctxt).

Definition may_start_new_voting_period (ctxt : Alpha_context.context)
  : Lwt.t (Error_monad.tzresult Alpha_context.context) :=
  let level := Alpha_context.Level.current ctxt in
  if last_of_a_voting_period ctxt level then
    start_new_voting_period ctxt
  else
    Error_monad.__return ctxt.

Amendment_mli

  • OCaml size: 75 lines
  • Coq size: 30 lines (-60% compared to OCaml)
amendment.mli 2 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(**
   Only delegates with at least one roll take part in the amendment procedure.
   It works as follows:
   - Proposal period: delegates can submit protocol amendment proposals using
     the proposal operation. At the end of a proposal period, the proposal with
     most supporters is selected and we move to a testing_vote period.
     If there are no proposals, or a tie between proposals, a new proposal
     period starts.
   - Testing_vote period: delegates can cast votes to test or not the winning
     proposal using the ballot operation.
     At the end of a testing_vote period if participation reaches the quorum
     and the proposal has a supermajority in favor, we proceed to a testing
     period. Otherwise we go back to a proposal period.
     In any case, if there is enough participation the quorum is updated.
   - Testing period: a test chain is forked for the lengh of the period.
     At the end of a testing period we move to a promotion_vote period.
   - Promotion_vote period: delegates can cast votes to promote or not the
     tested proposal using the ballot operation.
     At the end of a promotion_vote period if participation reaches the quorum
     and the tested proposal has a supermajority in favor, it is activated as
     the new protocol. Otherwise we go back to a proposal period.
     In any case, if there is enough participation the quorum is updated.
*)

open Alpha_context

(** If at the end of a voting period, moves to the next one following
    the state machine of the amendment procedure. *)
val may_start_new_voting_period : context -> context tzresult Lwt.t

type error +=
  | Unexpected_proposal
  | Unauthorized_proposal
  | Too_many_proposals
  | Empty_proposal

(** Records a list of proposals for a delegate.
    @raise Unexpected_proposal if [ctxt] is not in a proposal period.
    @raise Unauthorized_proposal if [delegate] is not in the listing. *)
val record_proposals :
  context -> public_key_hash -> Protocol_hash.t list -> context tzresult Lwt.t

type error += Invalid_proposal | Unexpected_ballot | Unauthorized_ballot

val record_ballot :
  context ->
  public_key_hash ->
  Protocol_hash.t ->
  Vote.ballot ->
  context tzresult Lwt.t
Amendment_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.

Parameter may_start_new_voting_period :
  Alpha_context.context -> Lwt.t (Error_monad.tzresult Alpha_context.context).

(* extensible_type error *)

Parameter record_proposals :
  Alpha_context.context -> Alpha_context.public_key_hash ->
  list (|Protocol_hash|).(S.HASH.t) ->
  Lwt.t (Error_monad.tzresult Alpha_context.context).

(* extensible_type error *)

Parameter record_ballot :
  Alpha_context.context -> Alpha_context.public_key_hash ->
  (|Protocol_hash|).(S.HASH.t) -> Alpha_context.Vote.ballot ->
  Lwt.t (Error_monad.tzresult Alpha_context.context).

Apply

  • OCaml size: 1487 lines
  • Coq size: 1863 lines (+25% compared to OCaml)
apply.ml 69 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Implementation - Main Entry Points *)

open Alpha_context

type error += Wrong_voting_period of Voting_period.t * Voting_period.t

(* `Temporary *)

type error += Wrong_endorsement_predecessor of Block_hash.t * Block_hash.t

(* `Temporary *)

type error += Duplicate_endorsement of Signature.Public_key_hash.t

(* `Branch *)

type error += Invalid_endorsement_level

type error += Invalid_commitment of {expected : bool}

type error += Internal_operation_replay of packed_internal_operation

type error += Invalid_double_endorsement_evidence (* `Permanent *)

type error +=
  | Inconsistent_double_endorsement_evidence of {
      delegate1 : Signature.Public_key_hash.t;
      delegate2 : Signature.Public_key_hash.t;
    }

(* `Permanent *)

type error += Unrequired_double_endorsement_evidence (* `Branch*)

type error +=
  | Too_early_double_endorsement_evidence of {
      level : Raw_level.t;
      current : Raw_level.t;
    }

(* `Temporary *)

type error +=
  | Outdated_double_endorsement_evidence of {
      level : Raw_level.t;
      last : Raw_level.t;
    }

(* `Permanent *)

type error +=
  | Invalid_double_baking_evidence of {
      hash1 : Block_hash.t;
      level1 : Int32.t;
      hash2 : Block_hash.t;
      level2 : Int32.t;
    }

(* `Permanent *)

type error +=
  | Inconsistent_double_baking_evidence of {
      delegate1 : Signature.Public_key_hash.t;
      delegate2 : Signature.Public_key_hash.t;
    }

(* `Permanent *)

type error += Unrequired_double_baking_evidence (* `Branch*)

type error +=
  | Too_early_double_baking_evidence of {
      level : Raw_level.t;
      current : Raw_level.t;
    }

(* `Temporary *)

type error +=
  | Outdated_double_baking_evidence of {
      level : Raw_level.t;
      last : Raw_level.t;
    }

(* `Permanent *)

type error += Invalid_activation of {pkh : Ed25519.Public_key_hash.t}

type error += Multiple_revelation

type error += Gas_quota_exceeded_init_deserialize (* Permanent *)

type error +=
  | Not_enough_endorsements_for_priority of {
      required : int;
      priority : int;
      endorsements : int;
      timestamp : Time.t;
    }

let () =
  register_error_kind
    `Temporary
    ~id:"operation.wrong_endorsement_predecessor"
    ~title:"Wrong endorsement predecessor"
    ~description:
      "Trying to include an endorsement in a block that is not the successor \
       of the endorsed one"
    ~pp:(fun ppf (e, p) ->
      Format.fprintf
        ppf
        "Wrong predecessor %a, expected %a"
        Block_hash.pp
        p
        Block_hash.pp
        e)
    Data_encoding.(
      obj2
        (req "expected" Block_hash.encoding)
        (req "provided" Block_hash.encoding))
    (function
      | Wrong_endorsement_predecessor (e, p) -> Some (e, p) | _ -> None)
    (fun (e, p) -> Wrong_endorsement_predecessor (e, p)) ;
  register_error_kind
    `Temporary
    ~id:"operation.wrong_voting_period"
    ~title:"Wrong voting period"
    ~description:
      "Trying to onclude a proposal or ballot meant for another voting period"
    ~pp:(fun ppf (e, p) ->
      Format.fprintf
        ppf
        "Wrong voting period %a, current is %a"
        Voting_period.pp
        p
        Voting_period.pp
        e)
    Data_encoding.(
      obj2
        (req "current" Voting_period.encoding)
        (req "provided" Voting_period.encoding))
    (function Wrong_voting_period (e, p) -> Some (e, p) | _ -> None)
    (fun (e, p) -> Wrong_voting_period (e, p)) ;
  register_error_kind
    `Branch
    ~id:"operation.duplicate_endorsement"
    ~title:"Duplicate endorsement"
    ~description:"Two endorsements received from same delegate"
    ~pp:(fun ppf k ->
      Format.fprintf
        ppf
        "Duplicate endorsement from delegate %a (possible replay attack)."
        Signature.Public_key_hash.pp_short
        k)
    Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
    (function Duplicate_endorsement k -> Some k | _ -> None)
    (fun k -> Duplicate_endorsement k) ;
  register_error_kind
    `Temporary
    ~id:"operation.invalid_endorsement_level"
    ~title:"Unexpected level in endorsement"
    ~description:
      "The level of an endorsement is inconsistent with the  provided block \
       hash."
    ~pp:(fun ppf () -> Format.fprintf ppf "Unexpected level in endorsement.")
    Data_encoding.unit
    (function Invalid_endorsement_level -> Some () | _ -> None)
    (fun () -> Invalid_endorsement_level) ;
  register_error_kind
    `Permanent
    ~id:"block.invalid_commitment"
    ~title:"Invalid commitment in block header"
    ~description:"The block header has invalid commitment."
    ~pp:(fun ppf expected ->
      if expected then
        Format.fprintf ppf "Missing seed's nonce commitment in block header."
      else
        Format.fprintf
          ppf
          "Unexpected seed's nonce commitment in block header.")
    Data_encoding.(obj1 (req "expected" bool))
    (function Invalid_commitment {expected} -> Some expected | _ -> None)
    (fun expected -> Invalid_commitment {expected}) ;
  register_error_kind
    `Permanent
    ~id:"internal_operation_replay"
    ~title:"Internal operation replay"
    ~description:"An internal operation was emitted twice by a script"
    ~pp:(fun ppf (Internal_operation {nonce; _}) ->
      Format.fprintf
        ppf
        "Internal operation %d was emitted twice by a script"
        nonce)
    Operation.internal_operation_encoding
    (function Internal_operation_replay op -> Some op | _ -> None)
    (fun op -> Internal_operation_replay op) ;
  register_error_kind
    `Permanent
    ~id:"block.invalid_double_endorsement_evidence"
    ~title:"Invalid double endorsement evidence"
    ~description:"A double-endorsement evidence is malformed"
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Malformed double-endorsement evidence")
    Data_encoding.empty
    (function Invalid_double_endorsement_evidence -> Some () | _ -> None)
    (fun () -> Invalid_double_endorsement_evidence) ;
  register_error_kind
    `Permanent
    ~id:"block.inconsistent_double_endorsement_evidence"
    ~title:"Inconsistent double endorsement evidence"
    ~description:
      "A double-endorsement evidence is inconsistent  (two distinct delegates)"
    ~pp:(fun ppf (delegate1, delegate2) ->
      Format.fprintf
        ppf
        "Inconsistent double-endorsement evidence  (distinct delegate: %a and \
         %a)"
        Signature.Public_key_hash.pp_short
        delegate1
        Signature.Public_key_hash.pp_short
        delegate2)
    Data_encoding.(
      obj2
        (req "delegate1" Signature.Public_key_hash.encoding)
        (req "delegate2" Signature.Public_key_hash.encoding))
    (function
      | Inconsistent_double_endorsement_evidence {delegate1; delegate2} ->
          Some (delegate1, delegate2)
      | _ ->
          None)
    (fun (delegate1, delegate2) ->
      Inconsistent_double_endorsement_evidence {delegate1; delegate2}) ;
  register_error_kind
    `Branch
    ~id:"block.unrequired_double_endorsement_evidence"
    ~title:"Unrequired double endorsement evidence"
    ~description:"A double-endorsement evidence is unrequired"
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "A valid double-endorsement operation cannot  be applied: the \
         associated delegate  has previously been denunciated in this cycle.")
    Data_encoding.empty
    (function Unrequired_double_endorsement_evidence -> Some () | _ -> None)
    (fun () -> Unrequired_double_endorsement_evidence) ;
  register_error_kind
    `Temporary
    ~id:"block.too_early_double_endorsement_evidence"
    ~title:"Too early double endorsement evidence"
    ~description:"A double-endorsement evidence is in the future"
    ~pp:(fun ppf (level, current) ->
      Format.fprintf
        ppf
        "A double-endorsement evidence is in the future  (current level: %a, \
         endorsement level: %a)"
        Raw_level.pp
        current
        Raw_level.pp
        level)
    Data_encoding.(
      obj2 (req "level" Raw_level.encoding) (req "current" Raw_level.encoding))
    (function
      | Too_early_double_endorsement_evidence {level; current} ->
          Some (level, current)
      | _ ->
          None)
    (fun (level, current) ->
      Too_early_double_endorsement_evidence {level; current}) ;
  register_error_kind
    `Permanent
    ~id:"block.outdated_double_endorsement_evidence"
    ~title:"Outdated double endorsement evidence"
    ~description:"A double-endorsement evidence is outdated."
    ~pp:(fun ppf (level, last) ->
      Format.fprintf
        ppf
        "A double-endorsement evidence is outdated  (last acceptable level: \
         %a, endorsement level: %a)"
        Raw_level.pp
        last
        Raw_level.pp
        level)
    Data_encoding.(
      obj2 (req "level" Raw_level.encoding) (req "last" Raw_level.encoding))
    (function
      | Outdated_double_endorsement_evidence {level; last} ->
          Some (level, last)
      | _ ->
          None)
    (fun (level, last) -> Outdated_double_endorsement_evidence {level; last}) ;
  register_error_kind
    `Permanent
    ~id:"block.invalid_double_baking_evidence"
    ~title:"Invalid double baking evidence"
    ~description:
      "A double-baking evidence is inconsistent  (two distinct level)"
    ~pp:(fun ppf (hash1, level1, hash2, level2) ->
      Format.fprintf
        ppf
        "Invalid double-baking evidence (hash: %a and %a, levels: %ld and %ld)"
        Block_hash.pp
        hash1
        Block_hash.pp
        hash2
        level1
        level2)
    Data_encoding.(
      obj4
        (req "hash1" Block_hash.encoding)
        (req "level1" int32)
        (req "hash2" Block_hash.encoding)
        (req "level2" int32))
    (function
      | Invalid_double_baking_evidence {hash1; level1; hash2; level2} ->
          Some (hash1, level1, hash2, level2)
      | _ ->
          None)
    (fun (hash1, level1, hash2, level2) ->
      Invalid_double_baking_evidence {hash1; level1; hash2; level2}) ;
  register_error_kind
    `Permanent
    ~id:"block.inconsistent_double_baking_evidence"
    ~title:"Inconsistent double baking evidence"
    ~description:
      "A double-baking evidence is inconsistent  (two distinct delegates)"
    ~pp:(fun ppf (delegate1, delegate2) ->
      Format.fprintf
        ppf
        "Inconsistent double-baking evidence  (distinct delegate: %a and %a)"
        Signature.Public_key_hash.pp_short
        delegate1
        Signature.Public_key_hash.pp_short
        delegate2)
    Data_encoding.(
      obj2
        (req "delegate1" Signature.Public_key_hash.encoding)
        (req "delegate2" Signature.Public_key_hash.encoding))
    (function
      | Inconsistent_double_baking_evidence {delegate1; delegate2} ->
          Some (delegate1, delegate2)
      | _ ->
          None)
    (fun (delegate1, delegate2) ->
      Inconsistent_double_baking_evidence {delegate1; delegate2}) ;
  register_error_kind
    `Branch
    ~id:"block.unrequired_double_baking_evidence"
    ~title:"Unrequired double baking evidence"
    ~description:"A double-baking evidence is unrequired"
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "A valid double-baking operation cannot  be applied: the associated \
         delegate  has previously been denunciated in this cycle.")
    Data_encoding.empty
    (function Unrequired_double_baking_evidence -> Some () | _ -> None)
    (fun () -> Unrequired_double_baking_evidence) ;
  register_error_kind
    `Temporary
    ~id:"block.too_early_double_baking_evidence"
    ~title:"Too early double baking evidence"
    ~description:"A double-baking evidence is in the future"
    ~pp:(fun ppf (level, current) ->
      Format.fprintf
        ppf
        "A double-baking evidence is in the future  (current level: %a, \
         baking level: %a)"
        Raw_level.pp
        current
        Raw_level.pp
        level)
    Data_encoding.(
      obj2 (req "level" Raw_level.encoding) (req "current" Raw_level.encoding))
    (function
      | Too_early_double_baking_evidence {level; current} ->
          Some (level, current)
      | _ ->
          None)
    (fun (level, current) -> Too_early_double_baking_evidence {level; current}) ;
  register_error_kind
    `Permanent
    ~id:"block.outdated_double_baking_evidence"
    ~title:"Outdated double baking evidence"
    ~description:"A double-baking evidence is outdated."
    ~pp:(fun ppf (level, last) ->
      Format.fprintf
        ppf
        "A double-baking evidence is outdated  (last acceptable level: %a, \
         baking level: %a)"
        Raw_level.pp
        last
        Raw_level.pp
        level)
    Data_encoding.(
      obj2 (req "level" Raw_level.encoding) (req "last" Raw_level.encoding))
    (function
      | Outdated_double_baking_evidence {level; last} ->
          Some (level, last)
      | _ ->
          None)
    (fun (level, last) -> Outdated_double_baking_evidence {level; last}) ;
  register_error_kind
    `Permanent
    ~id:"operation.invalid_activation"
    ~title:"Invalid activation"
    ~description:
      "The given key and secret do not correspond to any existing \
       preallocated contract"
    ~pp:(fun ppf pkh ->
      Format.fprintf
        ppf
        "Invalid activation. The public key %a does not match any commitment."
        Ed25519.Public_key_hash.pp
        pkh)
    Data_encoding.(obj1 (req "pkh" Ed25519.Public_key_hash.encoding))
    (function Invalid_activation {pkh} -> Some pkh | _ -> None)
    (fun pkh -> Invalid_activation {pkh}) ;
  register_error_kind
    `Permanent
    ~id:"block.multiple_revelation"
    ~title:"Multiple revelations were included in a manager operation"
    ~description:
      "A manager operation should not contain more than one revelation"
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "Multiple revelations were included in a manager operation")
    Data_encoding.empty
    (function Multiple_revelation -> Some () | _ -> None)
    (fun () -> Multiple_revelation) ;
  register_error_kind
    `Permanent
    ~id:"gas_exhausted.init_deserialize"
    ~title:"Not enough gas for initial deserialization of script expresions"
    ~description:
      "Gas limit was not high enough to deserialize the transaction \
       parameters or origination script code or initial storage, making the \
       operation impossible to parse within the provided gas bounds."
    Data_encoding.empty
    (function Gas_quota_exceeded_init_deserialize -> Some () | _ -> None)
    (fun () -> Gas_quota_exceeded_init_deserialize) ;
  register_error_kind
    `Permanent
    ~id:"operation.not_enought_endorsements_for_priority"
    ~title:"Not enough endorsements for priority"
    ~description:
      "The block being validated does not include the required minimum number \
       of endorsements for this priority."
    ~pp:(fun ppf (required, endorsements, priority, timestamp) ->
      Format.fprintf
        ppf
        "Wrong number of endorsements (%i) for priority (%i), %i are expected \
         at %a"
        endorsements
        priority
        required
        Time.pp_hum
        timestamp)
    Data_encoding.(
      obj4
        (req "required" int31)
        (req "endorsements" int31)
        (req "priority" int31)
        (req "timestamp" Time.encoding))
    (function
      | Not_enough_endorsements_for_priority
          {required; endorsements; priority; timestamp} ->
          Some (required, endorsements, priority, timestamp)
      | _ ->
          None)
    (fun (required, endorsements, priority, timestamp) ->
      Not_enough_endorsements_for_priority
        {required; endorsements; priority; timestamp})

open Apply_results

let apply_manager_operation_content :
    type kind.
    Alpha_context.t ->
    Script_ir_translator.unparsing_mode ->
    payer:Contract.t ->
    source:Contract.t ->
    chain_id:Chain_id.t ->
    internal:bool ->
    kind manager_operation ->
    ( context
    * kind successful_manager_operation_result
    * packed_internal_operation list )
    tzresult
    Lwt.t =
 fun ctxt mode ~payer ~source ~chain_id ~internal operation ->
  let before_operation =
    (* This context is not used for backtracking. Only to compute
         gas consumption and originations for the operation result. *)
    ctxt
  in
  Contract.must_exist ctxt source
  >>=? fun () ->
  Lwt.return (Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation)
  >>=? fun ctxt ->
  match operation with
  | Reveal _ ->
      return
        (* No-op: action already performed by `precheck_manager_contents`. *)
        ( ctxt,
          ( Reveal_result
              {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt}
            : kind successful_manager_operation_result ),
          [] )
  | Transaction {amount; parameters; destination; entrypoint} -> (
      Contract.spend ctxt source amount
      >>=? fun ctxt ->
      ( match Contract.is_implicit destination with
      | None ->
          return (ctxt, [], false)
      | Some _ -> (
          Contract.allocated ctxt destination
          >>=? function
          | true ->
              return (ctxt, [], false)
          | false ->
              Fees.origination_burn ctxt
              >>=? fun (ctxt, origination_burn) ->
              return
                ( ctxt,
                  [(Delegate.Contract payer, Delegate.Debited origination_burn)],
                  true ) ) )
      >>=? fun (ctxt, maybe_burn_balance_update, allocated_destination_contract)
               ->
      Contract.credit ctxt destination amount
      >>=? fun ctxt ->
      Contract.get_script ctxt destination
      >>=? fun (ctxt, script) ->
      match script with
      | None ->
          ( match entrypoint with
          | "default" ->
              return ()
          | entrypoint ->
              fail (Script_tc_errors.No_such_entrypoint entrypoint) )
          >>=? (fun () ->
                 Script.force_decode ctxt parameters
                 >>=? fun (arg, ctxt) ->
                 (* see [note] *)
                 (* [note]: for toplevel ops, cost is nil since the
               lazy value has already been forced at precheck, so
               we compute and consume the full cost again *)
                 let cost_arg = Script.deserialized_cost arg in
                 Lwt.return (Gas.consume ctxt cost_arg)
                 >>=? fun ctxt ->
                 match Micheline.root arg with
                 | Prim (_, D_Unit, [], _) ->
                     (* Allow [Unit] parameter to non-scripted contracts. *)
                     return ctxt
                 | _ ->
                     fail
                       (Script_interpreter.Bad_contract_parameter destination))
          >>=? fun ctxt ->
          let result =
            Transaction_result
              {
                storage = None;
                big_map_diff = None;
                balance_updates =
                  Delegate.cleanup_balance_updates
                    ( [ (Delegate.Contract source, Delegate.Debited amount);
                        (Contract destination, Credited amount) ]
                    @ maybe_burn_balance_update );
                originated_contracts = [];
                consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
                storage_size = Z.zero;
                paid_storage_size_diff = Z.zero;
                allocated_destination_contract;
              }
          in
          return (ctxt, result, [])
      | Some script ->
          Script.force_decode ctxt parameters
          >>=? fun (parameter, ctxt) ->
          (* see [note] *)
          let cost_parameter = Script.deserialized_cost parameter in
          Lwt.return (Gas.consume ctxt cost_parameter)
          >>=? fun ctxt ->
          let step_constants =
            let open Script_interpreter in
            {source; payer; self = destination; amount; chain_id}
          in
          Script_interpreter.execute
            ctxt
            mode
            step_constants
            ~script
            ~parameter
            ~entrypoint
          >>=? fun {ctxt; storage; big_map_diff; operations} ->
          Contract.update_script_storage ctxt destination storage big_map_diff
          >>=? fun ctxt ->
          Fees.record_paid_storage_space ctxt destination
          >>=? fun (ctxt, new_size, paid_storage_size_diff, fees) ->
          Contract.originated_from_current_nonce
            ~since:before_operation
            ~until:ctxt
          >>=? fun originated_contracts ->
          let result =
            Transaction_result
              {
                storage = Some storage;
                big_map_diff;
                balance_updates =
                  Delegate.cleanup_balance_updates
                    [ (Contract payer, Debited fees);
                      (Contract source, Debited amount);
                      (Contract destination, Credited amount) ];
                originated_contracts;
                consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
                storage_size = new_size;
                paid_storage_size_diff;
                allocated_destination_contract;
              }
          in
          return (ctxt, result, operations) )
  | Origination {delegate; script; preorigination; credit} ->
      Script.force_decode ctxt script.storage
      >>=? fun (unparsed_storage, ctxt) ->
      (* see [note] *)
      Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage))
      >>=? fun ctxt ->
      Script.force_decode ctxt script.code
      >>=? fun (unparsed_code, ctxt) ->
      (* see [note] *)
      Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code))
      >>=? fun ctxt ->
      Script_ir_translator.parse_script ctxt ~legacy:false script
      >>=? fun (Ex_script parsed_script, ctxt) ->
      Script_ir_translator.collect_big_maps
        ctxt
        parsed_script.storage_type
        parsed_script.storage
      >>=? fun (to_duplicate, ctxt) ->
      let to_update = Script_ir_translator.no_big_map_id in
      Script_ir_translator.extract_big_map_diff
        ctxt
        Optimized
        parsed_script.storage_type
        parsed_script.storage
        ~to_duplicate
        ~to_update
        ~temporary:false
      >>=? fun (storage, big_map_diff, ctxt) ->
      Script_ir_translator.unparse_data
        ctxt
        Optimized
        parsed_script.storage_type
        storage
      >>=? fun (storage, ctxt) ->
      let storage = Script.lazy_expr (Micheline.strip_locations storage) in
      let script = {script with storage} in
      Contract.spend ctxt source credit
      >>=? fun ctxt ->
      ( match preorigination with
      | Some contract ->
          assert internal ;
          (* The preorigination field is only used to early return
                 the address of an originated contract in Michelson.
                 It cannot come from the outside. *)
          return (ctxt, contract)
      | None ->
          Contract.fresh_contract_from_current_nonce ctxt )
      >>=? fun (ctxt, contract) ->
      Contract.originate
        ctxt
        contract
        ~delegate
        ~balance:credit
        ~script:(script, big_map_diff)
      >>=? fun ctxt ->
      Fees.origination_burn ctxt
      >>=? fun (ctxt, origination_burn) ->
      Fees.record_paid_storage_space ctxt contract
      >>=? fun (ctxt, size, paid_storage_size_diff, fees) ->
      let result =
        Origination_result
          {
            big_map_diff;
            balance_updates =
              Delegate.cleanup_balance_updates
                [ (Contract payer, Debited fees);
                  (Contract payer, Debited origination_burn);
                  (Contract source, Debited credit);
                  (Contract contract, Credited credit) ];
            originated_contracts = [contract];
            consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
            storage_size = size;
            paid_storage_size_diff;
          }
      in
      return (ctxt, result, [])
  | Delegation delegate ->
      Delegate.set ctxt source delegate
      >>=? fun ctxt ->
      return
        ( ctxt,
          Delegation_result
            {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt},
          [] )

let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops =
  let rec apply ctxt applied worklist =
    match worklist with
    | [] ->
        Lwt.return (`Success ctxt, List.rev applied)
    | Internal_operation ({source; operation; nonce} as op) :: rest -> (
        ( if internal_nonce_already_recorded ctxt nonce then
          fail (Internal_operation_replay (Internal_operation op))
        else
          let ctxt = record_internal_nonce ctxt nonce in
          apply_manager_operation_content
            ctxt
            mode
            ~source
            ~payer
            ~chain_id
            ~internal:true
            operation )
        >>= function
        | Error errors ->
            let result =
              Internal_operation_result
                (op, Failed (manager_kind op.operation, errors))
            in
            let skipped =
              List.rev_map
                (fun (Internal_operation op) ->
                  Internal_operation_result
                    (op, Skipped (manager_kind op.operation)))
                rest
            in
            Lwt.return (`Failure, List.rev (skipped @ (result :: applied)))
        | Ok (ctxt, result, emitted) ->
            apply
              ctxt
              (Internal_operation_result (op, Applied result) :: applied)
              (rest @ emitted) )
  in
  apply ctxt [] ops

let precheck_manager_contents (type kind) ctxt chain_id raw_operation
    (op : kind Kind.manager contents) : context tzresult Lwt.t =
  let (Manager_operation
        {source; fee; counter; operation; gas_limit; storage_limit}) =
    op
  in
  Lwt.return (Gas.check_limit ctxt gas_limit)
  >>=? fun () ->
  let ctxt = Gas.set_limit ctxt gas_limit in
  Lwt.return (Fees.check_storage_limit ctxt storage_limit)
  >>=? fun () ->
  Contract.must_be_allocated ctxt (Contract.implicit_contract source)
  >>=? fun () ->
  Contract.check_counter_increment ctxt source counter
  >>=? fun () ->
  ( match operation with
  | Reveal pk ->
      Contract.reveal_manager_key ctxt source pk
  | Transaction {parameters; _} ->
      (* Fail quickly if not enough gas for minimal deserialization cost *)
      Lwt.return
      @@ record_trace Gas_quota_exceeded_init_deserialize
      @@ Gas.check_enough ctxt (Script.minimal_deserialize_cost parameters)
      >>=? fun () ->
      (* Fail if not enough gas for complete deserialization cost *)
      trace Gas_quota_exceeded_init_deserialize
      @@ Script.force_decode ctxt parameters
      >>|? fun (_arg, ctxt) -> ctxt
  | Origination {script; _} ->
      (* Fail quickly if not enough gas for minimal deserialization cost *)
      Lwt.return
      @@ record_trace Gas_quota_exceeded_init_deserialize
      @@ ( Gas.consume ctxt (Script.minimal_deserialize_cost script.code)
         >>? fun ctxt ->
         Gas.check_enough ctxt (Script.minimal_deserialize_cost script.storage)
         )
      >>=? fun () ->
      (* Fail if not enough gas for complete deserialization cost *)
      trace Gas_quota_exceeded_init_deserialize
      @@ Script.force_decode ctxt script.code
      >>=? fun (_code, ctxt) ->
      trace Gas_quota_exceeded_init_deserialize
      @@ Script.force_decode ctxt script.storage
      >>|? fun (_storage, ctxt) -> ctxt
  | _ ->
      return ctxt )
  >>=? fun ctxt ->
  Contract.get_manager_key ctxt source
  >>=? fun public_key ->
  (* Currently, the `raw_operation` only contains one signature, so
     all operations are required to be from the same manager. This may
     change in the future, allowing several managers to group-sign a
     sequence of transactions.  *)
  Operation.check_signature public_key chain_id raw_operation
  >>=? fun () ->
  Contract.increment_counter ctxt source
  >>=? fun ctxt ->
  Contract.spend ctxt (Contract.implicit_contract source) fee
  >>=? fun ctxt -> add_fees ctxt fee >>=? fun ctxt -> return ctxt

let apply_manager_contents (type kind) ctxt mode chain_id
    (op : kind Kind.manager contents) :
    ( [`Success of context | `Failure]
    * kind manager_operation_result
    * packed_internal_operation_result list )
    Lwt.t =
  let (Manager_operation {source; operation; gas_limit; storage_limit}) = op in
  let ctxt = Gas.set_limit ctxt gas_limit in
  let ctxt = Fees.start_counting_storage_fees ctxt in
  let source = Contract.implicit_contract source in
  apply_manager_operation_content
    ctxt
    mode
    ~source
    ~payer:source
    ~internal:false
    ~chain_id
    operation
  >>= function
  | Ok (ctxt, operation_results, internal_operations) -> (
      apply_internal_manager_operations
        ctxt
        mode
        ~payer:source
        ~chain_id
        internal_operations
      >>= function
      | (`Success ctxt, internal_operations_results) -> (
          Fees.burn_storage_fees ctxt ~storage_limit ~payer:source
          >>= function
          | Ok ctxt ->
              Lwt.return
                ( `Success ctxt,
                  Applied operation_results,
                  internal_operations_results )
          | Error errors ->
              Lwt.return
                ( `Failure,
                  Backtracked (operation_results, Some errors),
                  internal_operations_results ) )
      | (`Failure, internal_operations_results) ->
          Lwt.return
            (`Failure, Applied operation_results, internal_operations_results)
      )
  | Error errors ->
      Lwt.return (`Failure, Failed (manager_kind operation, errors), [])

let skipped_operation_result :
    type kind. kind manager_operation -> kind manager_operation_result =
  function
  | operation -> (
    match operation with
    | Reveal _ ->
        Applied
          ( Reveal_result {consumed_gas = Z.zero}
            : kind successful_manager_operation_result )
    | _ ->
        Skipped (manager_kind operation) )

let rec mark_skipped :
    type kind.
    baker:Signature.Public_key_hash.t ->
    Level.t ->
    kind Kind.manager contents_list ->
    kind Kind.manager contents_result_list =
 fun ~baker level -> function
  | Single (Manager_operation {source; fee; operation}) ->
      let source = Contract.implicit_contract source in
      Single_result
        (Manager_operation_result
           {
             balance_updates =
               Delegate.cleanup_balance_updates
                 [ (Contract source, Debited fee);
                   (Fees (baker, level.cycle), Credited fee) ];
             operation_result = skipped_operation_result operation;
             internal_operation_results = [];
           })
  | Cons (Manager_operation {source; fee; operation}, rest) ->
      let source = Contract.implicit_contract source in
      Cons_result
        ( Manager_operation_result
            {
              balance_updates =
                Delegate.cleanup_balance_updates
                  [ (Contract source, Debited fee);
                    (Fees (baker, level.cycle), Credited fee) ];
              operation_result = skipped_operation_result operation;
              internal_operation_results = [];
            },
          mark_skipped ~baker level rest )

let rec precheck_manager_contents_list :
    type kind.
    Alpha_context.t ->
    Chain_id.t ->
    _ Operation.t ->
    kind Kind.manager contents_list ->
    context tzresult Lwt.t =
 fun ctxt chain_id raw_operation contents_list ->
  match contents_list with
  | Single (Manager_operation _ as op) ->
      precheck_manager_contents ctxt chain_id raw_operation op
  | Cons ((Manager_operation _ as op), rest) ->
      precheck_manager_contents ctxt chain_id raw_operation op
      >>=? fun ctxt ->
      precheck_manager_contents_list ctxt chain_id raw_operation rest

let rec apply_manager_contents_list_rec :
    type kind.
    Alpha_context.t ->
    Script_ir_translator.unparsing_mode ->
    public_key_hash ->
    Chain_id.t ->
    kind Kind.manager contents_list ->
    ([`Success of context | `Failure] * kind Kind.manager contents_result_list)
    Lwt.t =
 fun ctxt mode baker chain_id contents_list ->
  let level = Level.current ctxt in
  match contents_list with
  | Single (Manager_operation {source; fee; _} as op) ->
      let source = Contract.implicit_contract source in
      apply_manager_contents ctxt mode chain_id op
      >>= fun (ctxt_result, operation_result, internal_operation_results) ->
      let result =
        Manager_operation_result
          {
            balance_updates =
              Delegate.cleanup_balance_updates
                [ (Contract source, Debited fee);
                  (Fees (baker, level.cycle), Credited fee) ];
            operation_result;
            internal_operation_results;
          }
      in
      Lwt.return (ctxt_result, Single_result result)
  | Cons ((Manager_operation {source; fee; _} as op), rest) -> (
      let source = Contract.implicit_contract source in
      apply_manager_contents ctxt mode chain_id op
      >>= function
      | (`Failure, operation_result, internal_operation_results) ->
          let result =
            Manager_operation_result
              {
                balance_updates =
                  Delegate.cleanup_balance_updates
                    [ (Contract source, Debited fee);
                      (Fees (baker, level.cycle), Credited fee) ];
                operation_result;
                internal_operation_results;
              }
          in
          Lwt.return
            (`Failure, Cons_result (result, mark_skipped ~baker level rest))
      | (`Success ctxt, operation_result, internal_operation_results) ->
          let result =
            Manager_operation_result
              {
                balance_updates =
                  Delegate.cleanup_balance_updates
                    [ (Contract source, Debited fee);
                      (Fees (baker, level.cycle), Credited fee) ];
                operation_result;
                internal_operation_results;
              }
          in
          apply_manager_contents_list_rec ctxt mode baker chain_id rest
          >>= fun (ctxt_result, results) ->
          Lwt.return (ctxt_result, Cons_result (result, results)) )

let mark_backtracked results =
  let rec mark_contents_list :
      type kind.
      kind Kind.manager contents_result_list ->
      kind Kind.manager contents_result_list = function
    | Single_result (Manager_operation_result op) ->
        Single_result
          (Manager_operation_result
             {
               balance_updates = op.balance_updates;
               operation_result =
                 mark_manager_operation_result op.operation_result;
               internal_operation_results =
                 List.map
                   mark_internal_operation_results
                   op.internal_operation_results;
             })
    | Cons_result (Manager_operation_result op, rest) ->
        Cons_result
          ( Manager_operation_result
              {
                balance_updates = op.balance_updates;
                operation_result =
                  mark_manager_operation_result op.operation_result;
                internal_operation_results =
                  List.map
                    mark_internal_operation_results
                    op.internal_operation_results;
              },
            mark_contents_list rest )
  and mark_internal_operation_results
      (Internal_operation_result (kind, result)) =
    Internal_operation_result (kind, mark_manager_operation_result result)
  and mark_manager_operation_result :
      type kind. kind manager_operation_result -> kind manager_operation_result
      = function
    | (Failed _ | Skipped _ | Backtracked _) as result ->
        result
    | Applied (Reveal_result _) as result ->
        result
    | Applied result ->
        Backtracked (result, None)
  in
  mark_contents_list results

let apply_manager_contents_list ctxt mode baker chain_id contents_list =
  apply_manager_contents_list_rec ctxt mode baker chain_id contents_list
  >>= fun (ctxt_result, results) ->
  match ctxt_result with
  | `Failure ->
      Lwt.return (ctxt (* backtracked *), mark_backtracked results)
  | `Success ctxt ->
      Big_map.cleanup_temporary ctxt >>= fun ctxt -> Lwt.return (ctxt, results)

let apply_contents_list (type kind) ctxt chain_id mode pred_block baker
    (operation : kind operation) (contents_list : kind contents_list) :
    (context * kind contents_result_list) tzresult Lwt.t =
  match contents_list with
  | Single (Endorsement {level}) ->
      let block = operation.shell.branch in
      fail_unless
        (Block_hash.equal block pred_block)
        (Wrong_endorsement_predecessor (pred_block, block))
      >>=? fun () ->
      let current_level = (Level.current ctxt).level in
      fail_unless
        Raw_level.(succ level = current_level)
        Invalid_endorsement_level
      >>=? fun () ->
      Baking.check_endorsement_rights ctxt chain_id operation
      >>=? fun (delegate, slots, used) ->
      if used then fail (Duplicate_endorsement delegate)
      else
        let ctxt = record_endorsement ctxt delegate in
        let gap = List.length slots in
        Lwt.return
          Tez.(Constants.endorsement_security_deposit ctxt *? Int64.of_int gap)
        >>=? fun deposit ->
        Delegate.freeze_deposit ctxt delegate deposit
        >>=? fun ctxt ->
        Global.get_block_priority ctxt
        >>=? fun block_priority ->
        Baking.endorsing_reward ctxt ~block_priority gap
        >>=? fun reward ->
        Delegate.freeze_rewards ctxt delegate reward
        >>=? fun ctxt ->
        let level = Level.from_raw ctxt level in
        return
          ( ctxt,
            Single_result
              (Endorsement_result
                 {
                   balance_updates =
                     Delegate.cleanup_balance_updates
                       [ ( Contract (Contract.implicit_contract delegate),
                           Debited deposit );
                         (Deposits (delegate, level.cycle), Credited deposit);
                         (Rewards (delegate, level.cycle), Credited reward) ];
                   delegate;
                   slots;
                 }) )
  | Single (Seed_nonce_revelation {level; nonce}) ->
      let level = Level.from_raw ctxt level in
      Nonce.reveal ctxt level nonce
      >>=? fun ctxt ->
      let seed_nonce_revelation_tip =
        Constants.seed_nonce_revelation_tip ctxt
      in
      add_rewards ctxt seed_nonce_revelation_tip
      >>=? fun ctxt ->
      return
        ( ctxt,
          Single_result
            (Seed_nonce_revelation_result
               [ ( Rewards (baker, level.cycle),
                   Credited seed_nonce_revelation_tip ) ]) )
  | Single (Double_endorsement_evidence {op1; op2}) -> (
    match (op1.protocol_data.contents, op2.protocol_data.contents) with
    | (Single (Endorsement e1), Single (Endorsement e2))
      when Raw_level.(e1.level = e2.level)
           && not (Block_hash.equal op1.shell.branch op2.shell.branch) ->
        let level = Level.from_raw ctxt e1.level in
        let oldest_level = Level.last_allowed_fork_level ctxt in
        fail_unless
          Level.(level < Level.current ctxt)
          (Too_early_double_endorsement_evidence
             {level = level.level; current = (Level.current ctxt).level})
        >>=? fun () ->
        fail_unless
          Raw_level.(oldest_level <= level.level)
          (Outdated_double_endorsement_evidence
             {level = level.level; last = oldest_level})
        >>=? fun () ->
        Baking.check_endorsement_rights ctxt chain_id op1
        >>=? fun (delegate1, _, _) ->
        Baking.check_endorsement_rights ctxt chain_id op2
        >>=? fun (delegate2, _, _) ->
        fail_unless
          (Signature.Public_key_hash.equal delegate1 delegate2)
          (Inconsistent_double_endorsement_evidence {delegate1; delegate2})
        >>=? fun () ->
        Delegate.has_frozen_balance ctxt delegate1 level.cycle
        >>=? fun valid ->
        fail_unless valid Unrequired_double_endorsement_evidence
        >>=? fun () ->
        Delegate.punish ctxt delegate1 level.cycle
        >>=? fun (ctxt, balance) ->
        Lwt.return Tez.(balance.deposit +? balance.fees)
        >>=? fun burned ->
        let reward =
          match Tez.(burned /? 2L) with Ok v -> v | Error _ -> Tez.zero
        in
        add_rewards ctxt reward
        >>=? fun ctxt ->
        let current_cycle = (Level.current ctxt).cycle in
        return
          ( ctxt,
            Single_result
              (Double_endorsement_evidence_result
                 (Delegate.cleanup_balance_updates
                    [ ( Deposits (delegate1, level.cycle),
                        Debited balance.deposit );
                      (Fees (delegate1, level.cycle), Debited balance.fees);
                      ( Rewards (delegate1, level.cycle),
                        Debited balance.rewards );
                      (Rewards (baker, current_cycle), Credited reward) ])) )
    | (_, _) ->
        fail Invalid_double_endorsement_evidence )
  | Single (Double_baking_evidence {bh1; bh2}) ->
      let hash1 = Block_header.hash bh1 in
      let hash2 = Block_header.hash bh2 in
      fail_unless
        ( Compare.Int32.(bh1.shell.level = bh2.shell.level)
        && not (Block_hash.equal hash1 hash2) )
        (Invalid_double_baking_evidence
           {hash1; level1 = bh1.shell.level; hash2; level2 = bh2.shell.level})
      >>=? fun () ->
      Lwt.return (Raw_level.of_int32 bh1.shell.level)
      >>=? fun raw_level ->
      let oldest_level = Level.last_allowed_fork_level ctxt in
      fail_unless
        Raw_level.(raw_level < (Level.current ctxt).level)
        (Too_early_double_baking_evidence
           {level = raw_level; current = (Level.current ctxt).level})
      >>=? fun () ->
      fail_unless
        Raw_level.(oldest_level <= raw_level)
        (Outdated_double_baking_evidence
           {level = raw_level; last = oldest_level})
      >>=? fun () ->
      let level = Level.from_raw ctxt raw_level in
      Roll.baking_rights_owner
        ctxt
        level
        ~priority:bh1.protocol_data.contents.priority
      >>=? fun delegate1 ->
      Baking.check_signature bh1 chain_id delegate1
      >>=? fun () ->
      Roll.baking_rights_owner
        ctxt
        level
        ~priority:bh2.protocol_data.contents.priority
      >>=? fun delegate2 ->
      Baking.check_signature bh2 chain_id delegate2
      >>=? fun () ->
      fail_unless
        (Signature.Public_key.equal delegate1 delegate2)
        (Inconsistent_double_baking_evidence
           {
             delegate1 = Signature.Public_key.hash delegate1;
             delegate2 = Signature.Public_key.hash delegate2;
           })
      >>=? fun () ->
      let delegate = Signature.Public_key.hash delegate1 in
      Delegate.has_frozen_balance ctxt delegate level.cycle
      >>=? fun valid ->
      fail_unless valid Unrequired_double_baking_evidence
      >>=? fun () ->
      Delegate.punish ctxt delegate level.cycle
      >>=? fun (ctxt, balance) ->
      Lwt.return Tez.(balance.deposit +? balance.fees)
      >>=? fun burned ->
      let reward =
        match Tez.(burned /? 2L) with Ok v -> v | Error _ -> Tez.zero
      in
      add_rewards ctxt reward
      >>=? fun ctxt ->
      let current_cycle = (Level.current ctxt).cycle in
      return
        ( ctxt,
          Single_result
            (Double_baking_evidence_result
               (Delegate.cleanup_balance_updates
                  [ (Deposits (delegate, level.cycle), Debited balance.deposit);
                    (Fees (delegate, level.cycle), Debited balance.fees);
                    (Rewards (delegate, level.cycle), Debited balance.rewards);
                    (Rewards (baker, current_cycle), Credited reward) ])) )
  | Single (Activate_account {id = pkh; activation_code}) -> (
      let blinded_pkh =
        Blinded_public_key_hash.of_ed25519_pkh activation_code pkh
      in
      Commitment.get_opt ctxt blinded_pkh
      >>=? function
      | None ->
          fail (Invalid_activation {pkh})
      | Some amount ->
          Commitment.delete ctxt blinded_pkh
          >>=? fun ctxt ->
          let contract =
            Contract.implicit_contract (Signature.Ed25519Hash pkh)
          in
          Contract.(credit ctxt contract amount)
          >>=? fun ctxt ->
          return
            ( ctxt,
              Single_result
                (Activate_account_result [(Contract contract, Credited amount)])
            ) )
  | Single (Proposals {source; period; proposals}) ->
      Roll.delegate_pubkey ctxt source
      >>=? fun delegate ->
      Operation.check_signature delegate chain_id operation
      >>=? fun () ->
      let level = Level.current ctxt in
      fail_unless
        Voting_period.(level.voting_period = period)
        (Wrong_voting_period (level.voting_period, period))
      >>=? fun () ->
      Amendment.record_proposals ctxt source proposals
      >>=? fun ctxt -> return (ctxt, Single_result Proposals_result)
  | Single (Ballot {source; period; proposal; ballot}) ->
      Roll.delegate_pubkey ctxt source
      >>=? fun delegate ->
      Operation.check_signature delegate chain_id operation
      >>=? fun () ->
      let level = Level.current ctxt in
      fail_unless
        Voting_period.(level.voting_period = period)
        (Wrong_voting_period (level.voting_period, period))
      >>=? fun () ->
      Amendment.record_ballot ctxt source proposal ballot
      >>=? fun ctxt -> return (ctxt, Single_result Ballot_result)
  | Single (Manager_operation _) as op ->
      precheck_manager_contents_list ctxt chain_id operation op
      >>=? fun ctxt ->
      apply_manager_contents_list ctxt mode baker chain_id op
      >>= fun (ctxt, result) -> return (ctxt, result)
  | Cons (Manager_operation _, _) as op ->
      precheck_manager_contents_list ctxt chain_id operation op
      >>=? fun ctxt ->
      apply_manager_contents_list ctxt mode baker chain_id op
      >>= fun (ctxt, result) -> return (ctxt, result)

let apply_operation ctxt chain_id mode pred_block baker hash operation =
  let ctxt = Contract.init_origination_nonce ctxt hash in
  apply_contents_list
    ctxt
    chain_id
    mode
    pred_block
    baker
    operation
    operation.protocol_data.contents
  >>=? fun (ctxt, result) ->
  let ctxt = Gas.set_unlimited ctxt in
  let ctxt = Contract.unset_origination_nonce ctxt in
  return (ctxt, {contents = result})

let may_snapshot_roll ctxt =
  let level = Alpha_context.Level.current ctxt in
  let blocks_per_roll_snapshot = Constants.blocks_per_roll_snapshot ctxt in
  if
    Compare.Int32.equal
      (Int32.rem level.cycle_position blocks_per_roll_snapshot)
      (Int32.pred blocks_per_roll_snapshot)
  then Alpha_context.Roll.snapshot_rolls ctxt >>=? fun ctxt -> return ctxt
  else return ctxt

let may_start_new_cycle ctxt =
  Baking.dawn_of_a_new_cycle ctxt
  >>=? function
  | None ->
      return (ctxt, [], [])
  | Some last_cycle ->
      Seed.cycle_end ctxt last_cycle
      >>=? fun (ctxt, unrevealed) ->
      Roll.cycle_end ctxt last_cycle
      >>=? fun ctxt ->
      Delegate.cycle_end ctxt last_cycle unrevealed
      >>=? fun (ctxt, update_balances, deactivated) ->
      Bootstrap.cycle_end ctxt last_cycle
      >>=? fun ctxt -> return (ctxt, update_balances, deactivated)

let begin_full_construction ctxt pred_timestamp protocol_data =
  Alpha_context.Global.set_block_priority
    ctxt
    protocol_data.Block_header.priority
  >>=? fun ctxt ->
  Baking.check_baking_rights ctxt protocol_data pred_timestamp
  >>=? fun (delegate_pk, block_delay) ->
  let ctxt = Fitness.increase ctxt in
  match Level.pred ctxt (Level.current ctxt) with
  | None ->
      assert false (* genesis *)
  | Some pred_level ->
      Baking.endorsement_rights ctxt pred_level
      >>=? fun rights ->
      let ctxt = init_endorsements ctxt rights in
      return (ctxt, protocol_data, delegate_pk, block_delay)

let begin_partial_construction ctxt =
  let ctxt = Fitness.increase ctxt in
  match Level.pred ctxt (Level.current ctxt) with
  | None ->
      assert false (* genesis *)
  | Some pred_level ->
      Baking.endorsement_rights ctxt pred_level
      >>=? fun rights ->
      let ctxt = init_endorsements ctxt rights in
      return ctxt

let begin_application ctxt chain_id block_header pred_timestamp =
  Alpha_context.Global.set_block_priority
    ctxt
    block_header.Block_header.protocol_data.contents.priority
  >>=? fun ctxt ->
  let current_level = Alpha_context.Level.current ctxt in
  Baking.check_proof_of_work_stamp ctxt block_header
  >>=? fun () ->
  Baking.check_fitness_gap ctxt block_header
  >>=? fun () ->
  Baking.check_baking_rights
    ctxt
    block_header.protocol_data.contents
    pred_timestamp
  >>=? fun (delegate_pk, block_delay) ->
  Baking.check_signature block_header chain_id delegate_pk
  >>=? fun () ->
  let has_commitment =
    match block_header.protocol_data.contents.seed_nonce_hash with
    | None ->
        false
    | Some _ ->
        true
  in
  fail_unless
    Compare.Bool.(has_commitment = current_level.expected_commitment)
    (Invalid_commitment {expected = current_level.expected_commitment})
  >>=? fun () ->
  let ctxt = Fitness.increase ctxt in
  match Level.pred ctxt (Level.current ctxt) with
  | None ->
      assert false (* genesis *)
  | Some pred_level ->
      Baking.endorsement_rights ctxt pred_level
      >>=? fun rights ->
      let ctxt = init_endorsements ctxt rights in
      return (ctxt, delegate_pk, block_delay)

let check_minimum_endorsements ctxt protocol_data block_delay
    included_endorsements =
  let minimum = Baking.minimum_allowed_endorsements ctxt ~block_delay in
  let timestamp = Timestamp.current ctxt in
  fail_unless
    Compare.Int.(included_endorsements >= minimum)
    (Not_enough_endorsements_for_priority
       {
         required = minimum;
         priority = protocol_data.Block_header.priority;
         endorsements = included_endorsements;
         timestamp;
       })

let finalize_application ctxt protocol_data delegate ~block_delay =
  let included_endorsements = included_endorsements ctxt in
  check_minimum_endorsements
    ctxt
    protocol_data
    block_delay
    included_endorsements
  >>=? fun () ->
  let deposit = Constants.block_security_deposit ctxt in
  add_deposit ctxt delegate deposit
  >>=? fun ctxt ->
  Baking.baking_reward
    ctxt
    ~block_priority:protocol_data.priority
    ~included_endorsements
  >>=? fun reward ->
  add_rewards ctxt reward
  >>=? fun ctxt ->
  Signature.Public_key_hash.Map.fold
    (fun delegate deposit ctxt ->
      ctxt >>=? fun ctxt -> Delegate.freeze_deposit ctxt delegate deposit)
    (get_deposits ctxt)
    (return ctxt)
  >>=? fun ctxt ->
  (* end of level (from this point nothing should fail) *)
  let fees = Alpha_context.get_fees ctxt in
  Delegate.freeze_fees ctxt delegate fees
  >>=? fun ctxt ->
  let rewards = Alpha_context.get_rewards ctxt in
  Delegate.freeze_rewards ctxt delegate rewards
  >>=? fun ctxt ->
  ( match protocol_data.Block_header.seed_nonce_hash with
  | None ->
      return ctxt
  | Some nonce_hash ->
      Nonce.record_hash ctxt {nonce_hash; delegate; rewards; fees} )
  >>=? fun ctxt ->
  (* end of cycle *)
  may_snapshot_roll ctxt
  >>=? fun ctxt ->
  may_start_new_cycle ctxt
  >>=? fun (ctxt, balance_updates, deactivated) ->
  Amendment.may_start_new_voting_period ctxt
  >>=? fun ctxt ->
  let cycle = (Level.current ctxt).cycle in
  let balance_updates =
    Delegate.(
      cleanup_balance_updates
        ( [ (Contract (Contract.implicit_contract delegate), Debited deposit);
            (Deposits (delegate, cycle), Credited deposit);
            (Rewards (delegate, cycle), Credited reward) ]
        @ balance_updates ))
  in
  let consumed_gas =
    Z.sub
      (Constants.hard_gas_limit_per_block ctxt)
      (Alpha_context.Gas.block_level ctxt)
  in
  Alpha_context.Vote.get_current_period_kind ctxt
  >>=? fun voting_period_kind ->
  let receipt =
    Apply_results.
      {
        baker = delegate;
        level = Level.current ctxt;
        voting_period_kind;
        nonce_hash = protocol_data.seed_nonce_hash;
        consumed_gas;
        deactivated;
        balance_updates;
      }
  in
  return (ctxt, receipt)
Apply.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Amendment.
Require Tezos.Apply_results.
Require Tezos.Baking.
Require Tezos.Blinded_public_key_hash.
Require Tezos.Michelson_v1_gas.
Require Tezos.Script_interpreter.
Require Tezos.Script_ir_translator.
Require Tezos.Script_typed_ir.

Import Alpha_context.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Import Apply_results.

Definition apply_manager_operation_content {kind : Set}
  (ctxt : Alpha_context.t) (mode : Script_ir_translator.unparsing_mode)
  (payer : Alpha_context.Contract.t) (source : Alpha_context.Contract.t)
  (chain_id : (|Chain_id|).(S.HASH.t)) (internal : bool)
  (operation : Alpha_context.manager_operation kind)
  : Lwt.t
    (Error_monad.tzresult
      (Alpha_context.context *
        Apply_results.successful_manager_operation_result kind *
        list Alpha_context.packed_internal_operation)) :=
  let before_operation := ctxt in
  Error_monad.op_gtgteqquestion (Alpha_context.Contract.must_exist ctxt source)
    (fun function_parameter =>
      let '_ := function_parameter in
      Error_monad.op_gtgteqquestion
        (Lwt.__return
          (Alpha_context.Gas.consume ctxt
            Michelson_v1_gas.Cost_of.manager_operation))
        (fun ctxt =>
          match operation with
          | Alpha_context.Reveal _ =>
            Error_monad.__return
              (ctxt,
                (Apply_results.Reveal_result
                  {|
                    Apply_results.successful_manager_operation_result.Reveal_result.consumed_gas :=
                      Alpha_context.Gas.consumed before_operation ctxt |}), [])
          |
            Alpha_context.Transaction {|
              Alpha_context.manager_operation.Transaction.amount := amount;
                Alpha_context.manager_operation.Transaction.parameters :=
                  parameters;
                Alpha_context.manager_operation.Transaction.entrypoint :=
                  entrypoint;
                Alpha_context.manager_operation.Transaction.destination :=
                  destination
                |} =>
            Error_monad.op_gtgteqquestion
              (Alpha_context.Contract.spend ctxt source amount)
              (fun ctxt =>
                Error_monad.op_gtgteqquestion
                  match Alpha_context.Contract.is_implicit destination with
                  | None => Error_monad.__return (ctxt, [], false)
                  | Some _ =>
                    Error_monad.op_gtgteqquestion
                      (Alpha_context.Contract.allocated ctxt destination)
                      (fun function_parameter =>
                        match function_parameter with
                        | true => Error_monad.__return (ctxt, [], false)
                        | false =>
                          Error_monad.op_gtgteqquestion
                            (Alpha_context.Fees.origination_burn ctxt)
                            (fun function_parameter =>
                              let '(ctxt, origination_burn) :=
                                function_parameter in
                              Error_monad.__return
                                (ctxt,
                                  [
                                    ((Alpha_context.Delegate.Contract payer),
                                      (Alpha_context.Delegate.Debited
                                        origination_burn))
                                  ], true))
                        end)
                  end
                  (fun function_parameter =>
                    let
                      '(ctxt, maybe_burn_balance_update,
                        allocated_destination_contract) := function_parameter in
                    Error_monad.op_gtgteqquestion
                      (Alpha_context.Contract.credit ctxt destination amount)
                      (fun ctxt =>
                        Error_monad.op_gtgteqquestion
                          (Alpha_context.Contract.get_script ctxt destination)
                          (fun function_parameter =>
                            let '(ctxt, script) := function_parameter in
                            match script with
                            | None =>
                              Error_monad.op_gtgteqquestion
                                (Error_monad.op_gtgteqquestion
                                  match entrypoint with
                                  | "default" => Error_monad.__return tt
                                  | entrypoint =>
                                    Error_monad.fail extensible_type_value
                                  end
                                  (fun function_parameter =>
                                    let '_ := function_parameter in
                                    Error_monad.op_gtgteqquestion
                                      (Alpha_context.Script.force_decode ctxt
                                        parameters)
                                      (fun function_parameter =>
                                        let '(arg, ctxt) := function_parameter
                                          in
                                        let cost_arg :=
                                          Alpha_context.Script.deserialized_cost
                                            arg in
                                        Error_monad.op_gtgteqquestion
                                          (Lwt.__return
                                            (Alpha_context.Gas.consume ctxt
                                              cost_arg))
                                          (fun ctxt =>
                                            match Micheline.root arg with
                                            |
                                              Micheline.Prim _
                                                Alpha_context.Script.D_Unit [] _
                                              => Error_monad.__return ctxt
                                            | _ =>
                                              Error_monad.fail
                                                extensible_type_value
                                            end))))
                                (fun ctxt =>
                                  let __result_value :=
                                    Apply_results.Transaction_result
                                      {|
                                        Apply_results.successful_manager_operation_result.Transaction_result.storage :=
                                          None;
                                        Apply_results.successful_manager_operation_result.Transaction_result.big_map_diff :=
                                          None;
                                        Apply_results.successful_manager_operation_result.Transaction_result.balance_updates :=
                                          Alpha_context.Delegate.cleanup_balance_updates
                                            (Pervasives.op_at
                                              [
                                                ((Alpha_context.Delegate.Contract
                                                  source),
                                                  (Alpha_context.Delegate.Debited
                                                    amount));
                                                ((Alpha_context.Delegate.Contract
                                                  destination),
                                                  (Alpha_context.Delegate.Credited
                                                    amount))
                                              ] maybe_burn_balance_update);
                                        Apply_results.successful_manager_operation_result.Transaction_result.originated_contracts :=
                                          [];
                                        Apply_results.successful_manager_operation_result.Transaction_result.consumed_gas :=
                                          Alpha_context.Gas.consumed
                                            before_operation ctxt;
                                        Apply_results.successful_manager_operation_result.Transaction_result.storage_size :=
                                          Z.zero;
                                        Apply_results.successful_manager_operation_result.Transaction_result.paid_storage_size_diff :=
                                          Z.zero;
                                        Apply_results.successful_manager_operation_result.Transaction_result.allocated_destination_contract :=
                                          allocated_destination_contract |} in
                                  Error_monad.__return
                                    (ctxt, __result_value, []))
                            | Some script =>
                              Error_monad.op_gtgteqquestion
                                (Alpha_context.Script.force_decode ctxt
                                  parameters)
                                (fun function_parameter =>
                                  let '(parameter, ctxt) := function_parameter
                                    in
                                  let cost_parameter :=
                                    Alpha_context.Script.deserialized_cost
                                      parameter in
                                  Error_monad.op_gtgteqquestion
                                    (Lwt.__return
                                      (Alpha_context.Gas.consume ctxt
                                        cost_parameter))
                                    (fun ctxt =>
                                      let step_constants :=
                                        {|
                                          Script_interpreter.step_constants.source :=
                                            source;
                                          Script_interpreter.step_constants.payer :=
                                            payer;
                                          Script_interpreter.step_constants.self :=
                                            destination;
                                          Script_interpreter.step_constants.amount :=
                                            amount;
                                          Script_interpreter.step_constants.chain_id :=
                                            chain_id |} in
                                      Error_monad.op_gtgteqquestion
                                        (Script_interpreter.execute ctxt mode
                                          step_constants script entrypoint
                                          parameter)
                                        (fun function_parameter =>
                                          let '{|
                                            Script_interpreter.execution_result.ctxt := ctxt;
                                              Script_interpreter.execution_result.storage
                                                :=
                                                storage;
                                              Script_interpreter.execution_result.big_map_diff
                                                :=
                                                big_map_diff;
                                              Script_interpreter.execution_result.operations
                                                :=
                                                operations
                                              |} := function_parameter in
                                          Error_monad.op_gtgteqquestion
                                            (Alpha_context.Contract.update_script_storage
                                              ctxt destination storage
                                              big_map_diff)
                                            (fun ctxt =>
                                              Error_monad.op_gtgteqquestion
                                                (Alpha_context.Fees.record_paid_storage_space
                                                  ctxt destination)
                                                (fun function_parameter =>
                                                  let
                                                    '(ctxt, new_size,
                                                      paid_storage_size_diff,
                                                      fees) :=
                                                    function_parameter in
                                                  Error_monad.op_gtgteqquestion
                                                    (Alpha_context.Contract.originated_from_current_nonce
                                                      before_operation ctxt)
                                                    (fun originated_contracts =>
                                                      let __result_value :=
                                                        Apply_results.Transaction_result
                                                          {|
                                                            Apply_results.successful_manager_operation_result.Transaction_result.storage :=
                                                              Some storage;
                                                            Apply_results.successful_manager_operation_result.Transaction_result.big_map_diff :=
                                                              big_map_diff;
                                                            Apply_results.successful_manager_operation_result.Transaction_result.balance_updates :=
                                                              Alpha_context.Delegate.cleanup_balance_updates
                                                                [
                                                                  ((Alpha_context.Delegate.Contract
                                                                    payer),
                                                                    (Alpha_context.Delegate.Debited
                                                                      fees));
                                                                  ((Alpha_context.Delegate.Contract
                                                                    source),
                                                                    (Alpha_context.Delegate.Debited
                                                                      amount));
                                                                  ((Alpha_context.Delegate.Contract
                                                                    destination),
                                                                    (Alpha_context.Delegate.Credited
                                                                      amount))
                                                                ];
                                                            Apply_results.successful_manager_operation_result.Transaction_result.originated_contracts :=
                                                              originated_contracts;
                                                            Apply_results.successful_manager_operation_result.Transaction_result.consumed_gas :=
                                                              Alpha_context.Gas.consumed
                                                                before_operation
                                                                ctxt;
                                                            Apply_results.successful_manager_operation_result.Transaction_result.storage_size :=
                                                              new_size;
                                                            Apply_results.successful_manager_operation_result.Transaction_result.paid_storage_size_diff :=
                                                              paid_storage_size_diff;
                                                            Apply_results.successful_manager_operation_result.Transaction_result.allocated_destination_contract :=
                                                              allocated_destination_contract
                                                            |} in
                                                      Error_monad.__return
                                                        (ctxt, __result_value,
                                                          operations)))))))
                            end))))
          |
            Alpha_context.Origination {|
              Alpha_context.manager_operation.Origination.delegate := delegate;
                Alpha_context.manager_operation.Origination.script := script;
                Alpha_context.manager_operation.Origination.credit := credit;
                Alpha_context.manager_operation.Origination.preorigination :=
                  preorigination
                |} =>
            Error_monad.op_gtgteqquestion
              (Alpha_context.Script.force_decode ctxt
                (Alpha_context.Script.t.storage script))
              (fun function_parameter =>
                let '(unparsed_storage, ctxt) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Lwt.__return
                    (Alpha_context.Gas.consume ctxt
                      (Alpha_context.Script.deserialized_cost unparsed_storage)))
                  (fun ctxt =>
                    Error_monad.op_gtgteqquestion
                      (Alpha_context.Script.force_decode ctxt
                        (Alpha_context.Script.t.code script))
                      (fun function_parameter =>
                        let '(unparsed_code, ctxt) := function_parameter in
                        Error_monad.op_gtgteqquestion
                          (Lwt.__return
                            (Alpha_context.Gas.consume ctxt
                              (Alpha_context.Script.deserialized_cost
                                unparsed_code)))
                          (fun ctxt =>
                            Error_monad.op_gtgteqquestion
                              (Script_ir_translator.parse_script None ctxt false
                                script)
                              (fun function_parameter =>
                                let
                                  '(Script_ir_translator.Ex_script parsed_script,
                                    ctxt) := function_parameter in
                                Error_monad.op_gtgteqquestion
                                  (Script_ir_translator.collect_big_maps ctxt
                                    (Script_typed_ir.script.storage_type
                                      parsed_script)
                                    (Script_typed_ir.script.storage
                                      parsed_script))
                                  (fun function_parameter =>
                                    let '(to_duplicate, ctxt) :=
                                      function_parameter in
                                    let to_update :=
                                      Script_ir_translator.no_big_map_id in
                                    Error_monad.op_gtgteqquestion
                                      (Script_ir_translator.extract_big_map_diff
                                        ctxt Script_ir_translator.Optimized
                                        false to_duplicate to_update
                                        (Script_typed_ir.script.storage_type
                                          parsed_script)
                                        (Script_typed_ir.script.storage
                                          parsed_script))
                                      (fun function_parameter =>
                                        let '(storage, big_map_diff, ctxt) :=
                                          function_parameter in
                                        Error_monad.op_gtgteqquestion
                                          (Script_ir_translator.unparse_data
                                            ctxt Script_ir_translator.Optimized
                                            (Script_typed_ir.script.storage_type
                                              parsed_script) storage)
                                          (fun function_parameter =>
                                            let '(storage, ctxt) :=
                                              function_parameter in
                                            let storage :=
                                              Alpha_context.Script.__lazy_expr_value
                                                (Micheline.strip_locations
                                                  storage) in
                                            let script :=
                                              Alpha_context.Script.t.with_storage
                                                storage script in
                                            Error_monad.op_gtgteqquestion
                                              (Alpha_context.Contract.spend ctxt
                                                source credit)
                                              (fun ctxt =>
                                                Error_monad.op_gtgteqquestion
                                                  match preorigination with
                                                  | Some contract =>
                                                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                    (* ❌ instruction_sequence ";" *)
                                                    Error_monad.__return
                                                      (ctxt, contract)
                                                  | None =>
                                                    Alpha_context.Contract.fresh_contract_from_current_nonce
                                                      ctxt
                                                  end
                                                  (fun function_parameter =>
                                                    let '(ctxt, contract) :=
                                                      function_parameter in
                                                    Error_monad.op_gtgteqquestion
                                                      (Alpha_context.Contract.originate
                                                        ctxt contract credit
                                                        (script, big_map_diff)
                                                        delegate)
                                                      (fun ctxt =>
                                                        Error_monad.op_gtgteqquestion
                                                          (Alpha_context.Fees.origination_burn
                                                            ctxt)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            let
                                                              '(ctxt,
                                                                origination_burn) :=
                                                              function_parameter
                                                              in
                                                            Error_monad.op_gtgteqquestion
                                                              (Alpha_context.Fees.record_paid_storage_space
                                                                ctxt contract)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                let
                                                                  '(ctxt, size,
                                                                    paid_storage_size_diff,
                                                                    fees) :=
                                                                  function_parameter
                                                                  in
                                                                let
                                                                  __result_value :=
                                                                  Apply_results.Origination_result
                                                                    {|
                                                                      Apply_results.successful_manager_operation_result.Origination_result.big_map_diff :=
                                                                        big_map_diff;
                                                                      Apply_results.successful_manager_operation_result.Origination_result.balance_updates :=
                                                                        Alpha_context.Delegate.cleanup_balance_updates
                                                                          [
                                                                            ((Alpha_context.Delegate.Contract
                                                                              payer),
                                                                              (Alpha_context.Delegate.Debited
                                                                                fees));
                                                                            ((Alpha_context.Delegate.Contract
                                                                              payer),
                                                                              (Alpha_context.Delegate.Debited
                                                                                origination_burn));
                                                                            ((Alpha_context.Delegate.Contract
                                                                              source),
                                                                              (Alpha_context.Delegate.Debited
                                                                                credit));
                                                                            ((Alpha_context.Delegate.Contract
                                                                              contract),
                                                                              (Alpha_context.Delegate.Credited
                                                                                credit))
                                                                          ];
                                                                      Apply_results.successful_manager_operation_result.Origination_result.originated_contracts :=
                                                                        [
                                                                          contract
                                                                        ];
                                                                      Apply_results.successful_manager_operation_result.Origination_result.consumed_gas :=
                                                                        Alpha_context.Gas.consumed
                                                                          before_operation
                                                                          ctxt;
                                                                      Apply_results.successful_manager_operation_result.Origination_result.storage_size :=
                                                                        size;
                                                                      Apply_results.successful_manager_operation_result.Origination_result.paid_storage_size_diff :=
                                                                        paid_storage_size_diff
                                                                      |} in
                                                                Error_monad.__return
                                                                  (ctxt,
                                                                    __result_value,
                                                                    []))))))))))))))
          | Alpha_context.Delegation delegate =>
            Error_monad.op_gtgteqquestion
              (Alpha_context.Delegate.set ctxt source delegate)
              (fun ctxt =>
                Error_monad.__return
                  (ctxt,
                    (Apply_results.Delegation_result
                      {|
                        Apply_results.successful_manager_operation_result.Delegation_result.consumed_gas :=
                          Alpha_context.Gas.consumed before_operation ctxt |}),
                    []))
          end)).

Definition apply_internal_manager_operations
  (ctxt : Alpha_context.context) (mode : Script_ir_translator.unparsing_mode)
  (payer : Alpha_context.Contract.t) (chain_id : (|Chain_id|).(S.HASH.t))
  (ops : list Alpha_context.packed_internal_operation)
  : Lwt.t
    (((* `Success *) Alpha_context.context + (* `Failure *) unit) *
      list Apply_results.packed_internal_operation_result) :=
  let fix apply
    (ctxt : Alpha_context.context)
    (applied : list Apply_results.packed_internal_operation_result)
    (worklist : list Alpha_context.packed_internal_operation) {struct ctxt}
    : Lwt.t
      ((* `Success *) Alpha_context.context *
        list Apply_results.packed_internal_operation_result) :=
    match worklist with
    | [] =>
      Lwt.__return
        ((* ❌ Variants not supported *)
        (* ❌ `Success *)
        (Success ctxt), (List.rev applied))
    |
      cons
        (Alpha_context.Internal_operation
          ({|
            Alpha_context.internal_operation.source := source;
              Alpha_context.internal_operation.operation := operation;
              Alpha_context.internal_operation.nonce := __nonce_value
              |} as op)) rest =>
      Error_monad.op_gtgteq
        (if Alpha_context.internal_nonce_already_recorded ctxt __nonce_value
          then
          Error_monad.fail extensible_type_value
        else
          let ctxt := Alpha_context.record_internal_nonce ctxt __nonce_value in
          apply_manager_operation_content ctxt mode payer source chain_id true
            operation)
        (fun function_parameter =>
          match function_parameter with
          | Pervasives.Error errors =>
            let __result_value :=
              Apply_results.Internal_operation_result op
                (Apply_results.Failed
                  (Alpha_context.manager_kind
                    (Alpha_context.internal_operation.operation op)) errors) in
            let skipped :=
              List.rev_map
                (fun function_parameter =>
                  let 'Alpha_context.Internal_operation op := function_parameter
                    in
                  Apply_results.Internal_operation_result op
                    (Apply_results.Skipped
                      (Alpha_context.manager_kind
                        (Alpha_context.internal_operation.operation op)))) rest
              in
            Lwt.__return
              ((* ❌ Variants not supported *)
              (* ❌ `Failure *)
              Failure,
                (List.rev
                  (Pervasives.op_at skipped (cons __result_value applied))))
          | Pervasives.Ok (ctxt, __result_value, emitted) =>
            apply ctxt
              (cons
                (Apply_results.Internal_operation_result op
                  (Apply_results.Applied __result_value)) applied)
              (Pervasives.op_at rest emitted)
          end)
    end in
  apply ctxt [] ops.

Definition precheck_manager_contents {A B : Set}
  (ctxt : Alpha_context.context) (chain_id : (|Chain_id|).(S.HASH.t))
  (raw_operation : Alpha_context.operation A)
  (op : Alpha_context.contents (Alpha_context.Kind.manager B))
  : Lwt.t (Error_monad.tzresult Alpha_context.context) :=
  let
    'Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.source := source;
        Alpha_context.contents.Manager_operation.fee := fee;
        Alpha_context.contents.Manager_operation.counter := counter;
        Alpha_context.contents.Manager_operation.operation := operation;
        Alpha_context.contents.Manager_operation.gas_limit := gas_limit;
        Alpha_context.contents.Manager_operation.storage_limit := storage_limit
        |} := op in
  Error_monad.op_gtgteqquestion
    (Lwt.__return (Alpha_context.Gas.check_limit ctxt gas_limit))
    (fun function_parameter =>
      let '_ := function_parameter in
      let ctxt := Alpha_context.Gas.set_limit ctxt gas_limit in
      Error_monad.op_gtgteqquestion
        (Lwt.__return
          (Alpha_context.Fees.check_storage_limit ctxt storage_limit))
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgteqquestion
            (Alpha_context.Contract.must_be_allocated ctxt
              (Alpha_context.Contract.implicit_contract source))
            (fun function_parameter =>
              let '_ := function_parameter in
              Error_monad.op_gtgteqquestion
                (Alpha_context.Contract.check_counter_increment ctxt source
                  counter)
                (fun function_parameter =>
                  let '_ := function_parameter in
                  Error_monad.op_gtgteqquestion
                    match operation with
                    | Alpha_context.Reveal pk =>
                      Alpha_context.Contract.reveal_manager_key ctxt source pk
                    |
                      Alpha_context.Transaction {|
                        Alpha_context.manager_operation.Transaction.parameters := parameters
                          |} =>
                      Error_monad.op_gtgteqquestion
                        (Pervasives.op_atat Lwt.__return
                          (Pervasives.op_atat
                            (Error_monad.record_trace extensible_type_value)
                            (Alpha_context.Gas.check_enough ctxt
                              (Alpha_context.Script.minimal_deserialize_cost
                                parameters))))
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          Error_monad.op_gtgtpipequestion
                            (Pervasives.op_atat
                              (Error_monad.trace extensible_type_value)
                              (Alpha_context.Script.force_decode ctxt parameters))
                            (fun function_parameter =>
                              let '(_arg, ctxt) := function_parameter in
                              ctxt))
                    |
                      Alpha_context.Origination {|
                        Alpha_context.manager_operation.Origination.script := script
                          |} =>
                      Error_monad.op_gtgteqquestion
                        (Pervasives.op_atat Lwt.__return
                          (Pervasives.op_atat
                            (Error_monad.record_trace extensible_type_value)
                            (Error_monad.op_gtgtquestion
                              (Alpha_context.Gas.consume ctxt
                                (Alpha_context.Script.minimal_deserialize_cost
                                  (Alpha_context.Script.t.code script)))
                              (fun ctxt =>
                                Alpha_context.Gas.check_enough ctxt
                                  (Alpha_context.Script.minimal_deserialize_cost
                                    (Alpha_context.Script.t.storage script))))))
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          Error_monad.op_gtgteqquestion
                            (Pervasives.op_atat
                              (Error_monad.trace extensible_type_value)
                              (Alpha_context.Script.force_decode ctxt
                                (Alpha_context.Script.t.code script)))
                            (fun function_parameter =>
                              let '(_code, ctxt) := function_parameter in
                              Error_monad.op_gtgtpipequestion
                                (Pervasives.op_atat
                                  (Error_monad.trace extensible_type_value)
                                  (Alpha_context.Script.force_decode ctxt
                                    (Alpha_context.Script.t.storage script)))
                                (fun function_parameter =>
                                  let '(_storage, ctxt) := function_parameter in
                                  ctxt)))
                    | _ => Error_monad.__return ctxt
                    end
                    (fun ctxt =>
                      Error_monad.op_gtgteqquestion
                        (Alpha_context.Contract.get_manager_key ctxt source)
                        (fun public_key =>
                          Error_monad.op_gtgteqquestion
                            (Alpha_context.Operation.check_signature public_key
                              chain_id raw_operation)
                            (fun function_parameter =>
                              let '_ := function_parameter in
                              Error_monad.op_gtgteqquestion
                                (Alpha_context.Contract.increment_counter ctxt
                                  source)
                                (fun ctxt =>
                                  Error_monad.op_gtgteqquestion
                                    (Alpha_context.Contract.spend ctxt
                                      (Alpha_context.Contract.implicit_contract
                                        source) fee)
                                    (fun ctxt =>
                                      Error_monad.op_gtgteqquestion
                                        (Alpha_context.add_fees ctxt fee)
                                        (fun ctxt => Error_monad.__return ctxt)))))))))).

Definition apply_manager_contents {A : Set}
  (ctxt : Alpha_context.context) (mode : Script_ir_translator.unparsing_mode)
  (chain_id : (|Chain_id|).(S.HASH.t))
  (op : Alpha_context.contents (Alpha_context.Kind.manager A))
  : Lwt.t
    (((* `Failure *) unit + (* `Success *) Alpha_context.context) *
      Apply_results.manager_operation_result A *
      list Apply_results.packed_internal_operation_result) :=
  let
    'Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.source := source;
        Alpha_context.contents.Manager_operation.operation := operation;
        Alpha_context.contents.Manager_operation.gas_limit := gas_limit;
        Alpha_context.contents.Manager_operation.storage_limit := storage_limit
        |} := op in
  let ctxt := Alpha_context.Gas.set_limit ctxt gas_limit in
  let ctxt := Alpha_context.Fees.start_counting_storage_fees ctxt in
  let source := Alpha_context.Contract.implicit_contract source in
  Error_monad.op_gtgteq
    (apply_manager_operation_content ctxt mode source source chain_id false
      operation)
    (fun function_parameter =>
      match function_parameter with
      | Pervasives.Ok (ctxt, operation_results, internal_operations) =>
        Error_monad.op_gtgteq
          (apply_internal_manager_operations ctxt mode source chain_id
            internal_operations)
          (fun function_parameter =>
            match function_parameter with
            | (Success ctxt, internal_operations_results) =>
              Error_monad.op_gtgteq
                (Alpha_context.Fees.burn_storage_fees ctxt storage_limit source)
                (fun function_parameter =>
                  match function_parameter with
                  | Pervasives.Ok ctxt =>
                    Lwt.__return
                      ((* ❌ Variants not supported *)
                      (* ❌ `Success *)
                      (Success ctxt), (Apply_results.Applied operation_results),
                        internal_operations_results)
                  | Pervasives.Error errors =>
                    Lwt.__return
                      ((* ❌ Variants not supported *)
                      (* ❌ `Failure *)
                      Failure,
                        (Apply_results.Backtracked operation_results
                          (Some errors)), internal_operations_results)
                  end)
            | (Failure, internal_operations_results) =>
              Lwt.__return
                ((* ❌ Variants not supported *)
                (* ❌ `Failure *)
                Failure, (Apply_results.Applied operation_results),
                  internal_operations_results)
            end)
      | Pervasives.Error errors =>
        Lwt.__return
          ((* ❌ Variants not supported *)
          (* ❌ `Failure *)
          Failure,
            (Apply_results.Failed (Alpha_context.manager_kind operation) errors),
            [])
      end).

Definition skipped_operation_result {kind : Set}
  (operation : Alpha_context.manager_operation kind)
  : Apply_results.manager_operation_result kind :=
  match operation with
  | Alpha_context.Reveal _ =>
    Apply_results.Applied
      (Apply_results.Reveal_result
        {|
          Apply_results.successful_manager_operation_result.Reveal_result.consumed_gas :=
            Z.zero |})
  | _ => Apply_results.Skipped (Alpha_context.manager_kind operation)
  end.

Fixpoint mark_skipped {kind : Set}
  (baker : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (level : Alpha_context.Level.t)
  (function_parameter :
    Alpha_context.contents_list (Alpha_context.Kind.manager kind))
  {struct baker}
  : Apply_results.contents_result_list (Alpha_context.Kind.manager kind) :=
  match function_parameter with
  |
    Alpha_context.Single
      (Alpha_context.Manager_operation {|
        Alpha_context.contents.Manager_operation.source := source;
          Alpha_context.contents.Manager_operation.fee := fee;
          Alpha_context.contents.Manager_operation.operation := operation
          |}) =>
    let source := Alpha_context.Contract.implicit_contract source in
    Apply_results.Single_result
      (Apply_results.Manager_operation_result
        {|
          Apply_results.contents_result.Manager_operation_result.balance_updates :=
            Alpha_context.Delegate.cleanup_balance_updates
              [
                ((Alpha_context.Delegate.Contract source),
                  (Alpha_context.Delegate.Debited fee));
                ((Alpha_context.Delegate.Fees baker
                  (Alpha_context.Level.t.cycle level)),
                  (Alpha_context.Delegate.Credited fee))
              ];
          Apply_results.contents_result.Manager_operation_result.operation_result :=
            skipped_operation_result operation;
          Apply_results.contents_result.Manager_operation_result.internal_operation_results :=
            [] |})
  |
    Alpha_context.Cons
      (Alpha_context.Manager_operation {|
        Alpha_context.contents.Manager_operation.source := source;
          Alpha_context.contents.Manager_operation.fee := fee;
          Alpha_context.contents.Manager_operation.operation := operation
          |}) rest =>
    let source := Alpha_context.Contract.implicit_contract source in
    Apply_results.Cons_result
      (Apply_results.Manager_operation_result
        {|
          Apply_results.contents_result.Manager_operation_result.balance_updates :=
            Alpha_context.Delegate.cleanup_balance_updates
              [
                ((Alpha_context.Delegate.Contract source),
                  (Alpha_context.Delegate.Debited fee));
                ((Alpha_context.Delegate.Fees baker
                  (Alpha_context.Level.t.cycle level)),
                  (Alpha_context.Delegate.Credited fee))
              ];
          Apply_results.contents_result.Manager_operation_result.operation_result :=
            skipped_operation_result operation;
          Apply_results.contents_result.Manager_operation_result.internal_operation_results :=
            [] |}) (mark_skipped baker level rest)
  end.

Fixpoint precheck_manager_contents_list {A kind : Set}
  (ctxt : Alpha_context.t) (chain_id : (|Chain_id|).(S.HASH.t))
  (raw_operation : Alpha_context.Operation.t A)
  (contents_list : Alpha_context.contents_list (Alpha_context.Kind.manager kind))
  {struct ctxt} : Lwt.t (Error_monad.tzresult Alpha_context.context) :=
  match contents_list with
  | Alpha_context.Single ((Alpha_context.Manager_operation _) as op) =>
    precheck_manager_contents ctxt chain_id raw_operation op
  | Alpha_context.Cons ((Alpha_context.Manager_operation _) as op) rest =>
    Error_monad.op_gtgteqquestion
      (precheck_manager_contents ctxt chain_id raw_operation op)
      (fun ctxt =>
        precheck_manager_contents_list ctxt chain_id raw_operation rest)
  end.

Fixpoint apply_manager_contents_list_rec {kind : Set}
  (ctxt : Alpha_context.t) (mode : Script_ir_translator.unparsing_mode)
  (baker : Alpha_context.public_key_hash) (chain_id : (|Chain_id|).(S.HASH.t))
  (contents_list : Alpha_context.contents_list (Alpha_context.Kind.manager kind))
  {struct ctxt}
  : Lwt.t
    (((* `Failure *) unit + (* `Success *) Alpha_context.context) *
      Apply_results.contents_result_list (Alpha_context.Kind.manager kind)) :=
  let level := Alpha_context.Level.current ctxt in
  match contents_list with
  |
    Alpha_context.Single
      ((Alpha_context.Manager_operation {|
        Alpha_context.contents.Manager_operation.source := source;
          Alpha_context.contents.Manager_operation.fee := fee
          |}) as op) =>
    let source := Alpha_context.Contract.implicit_contract source in
    Error_monad.op_gtgteq (apply_manager_contents ctxt mode chain_id op)
      (fun function_parameter =>
        let '(ctxt_result, operation_result, internal_operation_results) :=
          function_parameter in
        let __result_value :=
          Apply_results.Manager_operation_result
            {|
              Apply_results.contents_result.Manager_operation_result.balance_updates :=
                Alpha_context.Delegate.cleanup_balance_updates
                  [
                    ((Alpha_context.Delegate.Contract source),
                      (Alpha_context.Delegate.Debited fee));
                    ((Alpha_context.Delegate.Fees baker
                      (Alpha_context.Level.t.cycle level)),
                      (Alpha_context.Delegate.Credited fee))
                  ];
              Apply_results.contents_result.Manager_operation_result.operation_result :=
                operation_result;
              Apply_results.contents_result.Manager_operation_result.internal_operation_results :=
                internal_operation_results |} in
        Lwt.__return (ctxt_result, (Apply_results.Single_result __result_value)))
  |
    Alpha_context.Cons
      ((Alpha_context.Manager_operation {|
        Alpha_context.contents.Manager_operation.source := source;
          Alpha_context.contents.Manager_operation.fee := fee
          |}) as op) rest =>
    let source := Alpha_context.Contract.implicit_contract source in
    Error_monad.op_gtgteq (apply_manager_contents ctxt mode chain_id op)
      (fun function_parameter =>
        match function_parameter with
        | (Failure, operation_result, internal_operation_results) =>
          let __result_value :=
            Apply_results.Manager_operation_result
              {|
                Apply_results.contents_result.Manager_operation_result.balance_updates :=
                  Alpha_context.Delegate.cleanup_balance_updates
                    [
                      ((Alpha_context.Delegate.Contract source),
                        (Alpha_context.Delegate.Debited fee));
                      ((Alpha_context.Delegate.Fees baker
                        (Alpha_context.Level.t.cycle level)),
                        (Alpha_context.Delegate.Credited fee))
                    ];
                Apply_results.contents_result.Manager_operation_result.operation_result :=
                  operation_result;
                Apply_results.contents_result.Manager_operation_result.internal_operation_results :=
                  internal_operation_results |} in
          Lwt.__return
            ((* ❌ Variants not supported *)
            (* ❌ `Failure *)
            Failure,
              (Apply_results.Cons_result __result_value
                (mark_skipped baker level rest)))
        | (Success ctxt, operation_result, internal_operation_results) =>
          let __result_value :=
            Apply_results.Manager_operation_result
              {|
                Apply_results.contents_result.Manager_operation_result.balance_updates :=
                  Alpha_context.Delegate.cleanup_balance_updates
                    [
                      ((Alpha_context.Delegate.Contract source),
                        (Alpha_context.Delegate.Debited fee));
                      ((Alpha_context.Delegate.Fees baker
                        (Alpha_context.Level.t.cycle level)),
                        (Alpha_context.Delegate.Credited fee))
                    ];
                Apply_results.contents_result.Manager_operation_result.operation_result :=
                  operation_result;
                Apply_results.contents_result.Manager_operation_result.internal_operation_results :=
                  internal_operation_results |} in
          Error_monad.op_gtgteq
            (apply_manager_contents_list_rec ctxt mode baker chain_id rest)
            (fun function_parameter =>
              let '(ctxt_result, results) := function_parameter in
              Lwt.__return
                (ctxt_result, (Apply_results.Cons_result __result_value results)))
        end)
  end.

Definition mark_backtracked {A : Set}
  (results : Apply_results.contents_result_list (Alpha_context.Kind.manager A))
  : Apply_results.contents_result_list (Alpha_context.Kind.manager A) :=
  let fix mark_contents_list {kind : Set}
    (function_parameter :
      Apply_results.contents_result_list (Alpha_context.Kind.manager kind))
    {struct function_parameter}
    : Apply_results.contents_result_list (Alpha_context.Kind.manager kind) :=
    match function_parameter with
    | Apply_results.Single_result (Apply_results.Manager_operation_result op) =>
      Apply_results.Single_result
        (Apply_results.Manager_operation_result
          {|
            Apply_results.contents_result.Manager_operation_result.balance_updates :=
              Apply_results.contents_result.Manager_operation_result.balance_updates
                op;
            Apply_results.contents_result.Manager_operation_result.operation_result :=
              mark_manager_operation_result
                (Apply_results.contents_result.Manager_operation_result.operation_result
                  op);
            Apply_results.contents_result.Manager_operation_result.internal_operation_results :=
              List.map mark_internal_operation_results
                (Apply_results.contents_result.Manager_operation_result.internal_operation_results
                  op) |})
    | Apply_results.Cons_result (Apply_results.Manager_operation_result op) rest
      =>
      Apply_results.Cons_result
        (Apply_results.Manager_operation_result
          {|
            Apply_results.contents_result.Manager_operation_result.balance_updates :=
              Apply_results.contents_result.Manager_operation_result.balance_updates
                op;
            Apply_results.contents_result.Manager_operation_result.operation_result :=
              mark_manager_operation_result
                (Apply_results.contents_result.Manager_operation_result.operation_result
                  op);
            Apply_results.contents_result.Manager_operation_result.internal_operation_results :=
              List.map mark_internal_operation_results
                (Apply_results.contents_result.Manager_operation_result.internal_operation_results
                  op) |}) (mark_contents_list rest)
    end
  with mark_internal_operation_results
    (function_parameter : Apply_results.packed_internal_operation_result)
    {struct function_parameter}
    : Apply_results.packed_internal_operation_result :=
    let 'Apply_results.Internal_operation_result kind __result_value :=
      function_parameter in
    Apply_results.Internal_operation_result kind
      (mark_manager_operation_result __result_value)
  with mark_manager_operation_result {kind : Set}
    (function_parameter : Apply_results.manager_operation_result kind)
    {struct function_parameter} : Apply_results.manager_operation_result kind :=
    match function_parameter with
    |
      (Apply_results.Failed _ _ | Apply_results.Skipped _ |
      Apply_results.Backtracked _ _) as __result_value => __result_value
    | (Apply_results.Applied (Apply_results.Reveal_result _)) as __result_value
      => __result_value
    | Apply_results.Applied __result_value =>
      Apply_results.Backtracked __result_value None
    end in
  mark_contents_list results.

Definition apply_manager_contents_list {A : Set}
  (ctxt : Alpha_context.t) (mode : Script_ir_translator.unparsing_mode)
  (baker : Alpha_context.public_key_hash) (chain_id : (|Chain_id|).(S.HASH.t))
  (contents_list : Alpha_context.contents_list (Alpha_context.Kind.manager A))
  : Lwt.t
    (Alpha_context.t *
      Apply_results.contents_result_list (Alpha_context.Kind.manager A)) :=
  Error_monad.op_gtgteq
    (apply_manager_contents_list_rec ctxt mode baker chain_id contents_list)
    (fun function_parameter =>
      let '(ctxt_result, results) := function_parameter in
      match ctxt_result with
      | Failure => Lwt.__return (ctxt, (mark_backtracked results))
      | Success ctxt =>
        Error_monad.op_gtgteq (Alpha_context.Big_map.cleanup_temporary ctxt)
          (fun ctxt => Lwt.__return (ctxt, results))
      end).

Definition apply_contents_list {A : Set}
  (ctxt : Alpha_context.context) (chain_id : (|Chain_id|).(S.HASH.t))
  (mode : Script_ir_translator.unparsing_mode)
  (pred_block : (|Block_hash|).(S.HASH.t))
  (baker : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (operation : Alpha_context.operation A)
  (contents_list : Alpha_context.contents_list A)
  : Lwt.t
    (Error_monad.tzresult
      (Alpha_context.context * Apply_results.contents_result_list A)) :=
  match contents_list with
  |
    Alpha_context.Single
      (Alpha_context.Endorsement {|
        Alpha_context.contents.Endorsement.level := level |}) =>
    let block :=
      Operation.shell_header.branch (Alpha_context.operation.shell operation) in
    Error_monad.op_gtgteqquestion
      (Error_monad.fail_unless ((|Block_hash|).(S.HASH.equal) block pred_block)
        extensible_type_value)
      (fun function_parameter =>
        let '_ := function_parameter in
        let current_level :=
          Alpha_context.Level.t.level (Alpha_context.Level.current ctxt) in
        Error_monad.op_gtgteqquestion
          (Error_monad.fail_unless
            (Alpha_context.Raw_level.op_eq (Alpha_context.Raw_level.succ level)
              current_level) extensible_type_value)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (Baking.check_endorsement_rights ctxt chain_id operation)
              (fun function_parameter =>
                let '(delegate, slots, used) := function_parameter in
                if used then
                  Error_monad.fail extensible_type_value
                else
                  let ctxt := Alpha_context.record_endorsement ctxt delegate in
                  let gap := List.length slots in
                  Error_monad.op_gtgteqquestion
                    (Lwt.__return
                      (Alpha_context.Tez.op_starquestion
                        (Alpha_context.Constants.endorsement_security_deposit
                          ctxt) (Int64.of_int gap)))
                    (fun deposit =>
                      Error_monad.op_gtgteqquestion
                        (Alpha_context.Delegate.freeze_deposit ctxt delegate
                          deposit)
                        (fun ctxt =>
                          Error_monad.op_gtgteqquestion
                            (Alpha_context.Global.get_block_priority ctxt)
                            (fun block_priority =>
                              Error_monad.op_gtgteqquestion
                                (Baking.endorsing_reward ctxt block_priority gap)
                                (fun reward =>
                                  Error_monad.op_gtgteqquestion
                                    (Alpha_context.Delegate.freeze_rewards ctxt
                                      delegate reward)
                                    (fun ctxt =>
                                      let level :=
                                        Alpha_context.Level.from_raw ctxt None
                                          level in
                                      Error_monad.__return
                                        (ctxt,
                                          (Apply_results.Single_result
                                            (Apply_results.Endorsement_result
                                              {|
                                                Apply_results.contents_result.Endorsement_result.balance_updates :=
                                                  Alpha_context.Delegate.cleanup_balance_updates
                                                    [
                                                      ((Alpha_context.Delegate.Contract
                                                        (Alpha_context.Contract.implicit_contract
                                                          delegate)),
                                                        (Alpha_context.Delegate.Debited
                                                          deposit));
                                                      ((Alpha_context.Delegate.Deposits
                                                        delegate
                                                        (Alpha_context.Level.t.cycle
                                                          level)),
                                                        (Alpha_context.Delegate.Credited
                                                          deposit));
                                                      ((Alpha_context.Delegate.Rewards
                                                        delegate
                                                        (Alpha_context.Level.t.cycle
                                                          level)),
                                                        (Alpha_context.Delegate.Credited
                                                          reward))
                                                    ];
                                                Apply_results.contents_result.Endorsement_result.delegate :=
                                                  delegate;
                                                Apply_results.contents_result.Endorsement_result.slots :=
                                                  slots |})))))))))))
  |
    Alpha_context.Single
      (Alpha_context.Seed_nonce_revelation {|
        Alpha_context.contents.Seed_nonce_revelation.level := level;
          Alpha_context.contents.Seed_nonce_revelation.nonce := __nonce_value
          |}) =>
    let level := Alpha_context.Level.from_raw ctxt None level in
    Error_monad.op_gtgteqquestion
      (Alpha_context.Nonce.reveal ctxt level __nonce_value)
      (fun ctxt =>
        let seed_nonce_revelation_tip :=
          Alpha_context.Constants.seed_nonce_revelation_tip ctxt in
        Error_monad.op_gtgteqquestion
          (Alpha_context.add_rewards ctxt seed_nonce_revelation_tip)
          (fun ctxt =>
            Error_monad.__return
              (ctxt,
                (Apply_results.Single_result
                  (Apply_results.Seed_nonce_revelation_result
                    [
                      ((Alpha_context.Delegate.Rewards baker
                        (Alpha_context.Level.t.cycle level)),
                        (Alpha_context.Delegate.Credited
                          seed_nonce_revelation_tip))
                    ])))))
  |
    Alpha_context.Single
      (Alpha_context.Double_endorsement_evidence {|
        Alpha_context.contents.Double_endorsement_evidence.op1 := op1;
          Alpha_context.contents.Double_endorsement_evidence.op2 := op2
          |}) =>
    match
      (((Alpha_context.protocol_data.contents
        (Alpha_context.operation.protocol_data op1)),
        (Alpha_context.protocol_data.contents
          (Alpha_context.operation.protocol_data op2))),
        match
          ((Alpha_context.protocol_data.contents
            (Alpha_context.operation.protocol_data op1)),
            (Alpha_context.protocol_data.contents
              (Alpha_context.operation.protocol_data op2))) with
        |
          (Alpha_context.Single (Alpha_context.Endorsement e1),
            Alpha_context.Single (Alpha_context.Endorsement e2)) =>
          Pervasives.op_andand
            (Alpha_context.Raw_level.op_eq
              (Alpha_context.contents.Endorsement.level e1)
              (Alpha_context.contents.Endorsement.level e2))
            (Pervasives.not
              ((|Block_hash|).(S.HASH.equal)
                (Operation.shell_header.branch
                  (Alpha_context.operation.shell op1))
                (Operation.shell_header.branch
                  (Alpha_context.operation.shell op2))))
        | _ => false
        end) with
    |
      ((Alpha_context.Single (Alpha_context.Endorsement e1),
        Alpha_context.Single (Alpha_context.Endorsement e2)), true) =>
      let level :=
        Alpha_context.Level.from_raw ctxt None
          (Alpha_context.contents.Endorsement.level e1) in
      let oldest_level := Alpha_context.Level.last_allowed_fork_level ctxt in
      Error_monad.op_gtgteqquestion
        (Error_monad.fail_unless
          (Alpha_context.Level.op_lt level (Alpha_context.Level.current ctxt))
          extensible_type_value)
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgteqquestion
            (Error_monad.fail_unless
              (Alpha_context.Raw_level.op_lteq oldest_level
                (Alpha_context.Level.t.level level)) extensible_type_value)
            (fun function_parameter =>
              let '_ := function_parameter in
              Error_monad.op_gtgteqquestion
                (Baking.check_endorsement_rights ctxt chain_id op1)
                (fun function_parameter =>
                  let '(delegate1, _, _) := function_parameter in
                  Error_monad.op_gtgteqquestion
                    (Baking.check_endorsement_rights ctxt chain_id op2)
                    (fun function_parameter =>
                      let '(delegate2, _, _) := function_parameter in
                      Error_monad.op_gtgteqquestion
                        (Error_monad.fail_unless
                          ((|Signature.Public_key_hash|).(S.SPublic_key_hash.equal)
                            delegate1 delegate2) extensible_type_value)
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          Error_monad.op_gtgteqquestion
                            (Alpha_context.Delegate.has_frozen_balance ctxt
                              delegate1 (Alpha_context.Level.t.cycle level))
                            (fun valid =>
                              Error_monad.op_gtgteqquestion
                                (Error_monad.fail_unless valid
                                  extensible_type_value)
                                (fun function_parameter =>
                                  let '_ := function_parameter in
                                  Error_monad.op_gtgteqquestion
                                    (Alpha_context.Delegate.punish ctxt
                                      delegate1
                                      (Alpha_context.Level.t.cycle level))
                                    (fun function_parameter =>
                                      let '(ctxt, balance) := function_parameter
                                        in
                                      Error_monad.op_gtgteqquestion
                                        (Lwt.__return
                                          (Alpha_context.Tez.op_plusquestion
                                            (Alpha_context.Delegate.frozen_balance.deposit
                                              balance)
                                            (Alpha_context.Delegate.frozen_balance.fees
                                              balance)))
                                        (fun burned =>
                                          let reward :=
                                            match
                                              Alpha_context.Tez.op_divquestion
                                                burned
                                                (* ❌ Constant of type int64 is converted to int *)
                                                2 with
                                            | Pervasives.Ok v => v
                                            | Pervasives.Error _ =>
                                              Alpha_context.Tez.zero
                                            end in
                                          Error_monad.op_gtgteqquestion
                                            (Alpha_context.add_rewards ctxt
                                              reward)
                                            (fun ctxt =>
                                              let current_cycle :=
                                                Alpha_context.Level.t.cycle
                                                  (Alpha_context.Level.current
                                                    ctxt) in
                                              Error_monad.__return
                                                (ctxt,
                                                  (Apply_results.Single_result
                                                    (Apply_results.Double_endorsement_evidence_result
                                                      (Alpha_context.Delegate.cleanup_balance_updates
                                                        [
                                                          ((Alpha_context.Delegate.Deposits
                                                            delegate1
                                                            (Alpha_context.Level.t.cycle
                                                              level)),
                                                            (Alpha_context.Delegate.Debited
                                                              (Alpha_context.Delegate.frozen_balance.deposit
                                                                balance)));
                                                          ((Alpha_context.Delegate.Fees
                                                            delegate1
                                                            (Alpha_context.Level.t.cycle
                                                              level)),
                                                            (Alpha_context.Delegate.Debited
                                                              (Alpha_context.Delegate.frozen_balance.fees
                                                                balance)));
                                                          ((Alpha_context.Delegate.Rewards
                                                            delegate1
                                                            (Alpha_context.Level.t.cycle
                                                              level)),
                                                            (Alpha_context.Delegate.Debited
                                                              (Alpha_context.Delegate.frozen_balance.rewards
                                                                balance)));
                                                          ((Alpha_context.Delegate.Rewards
                                                            baker
                                                            current_cycle),
                                                            (Alpha_context.Delegate.Credited
                                                              reward))
                                                        ]))))))))))))))
    | ((_, _), _) => Error_monad.fail extensible_type_value
    end
  |
    Alpha_context.Single
      (Alpha_context.Double_baking_evidence {|
        Alpha_context.contents.Double_baking_evidence.bh1 := bh1;
          Alpha_context.contents.Double_baking_evidence.bh2 := bh2
          |}) =>
    let hash1 := Alpha_context.Block_header.__hash_value bh1 in
    let hash2 := Alpha_context.Block_header.__hash_value bh2 in
    Error_monad.op_gtgteqquestion
      (Error_monad.fail_unless
        (Pervasives.op_andand
          ((|Compare.Int32|).(Compare.S.op_eq)
            (Block_header.shell_header.level
              (Alpha_context.Block_header.t.shell bh1))
            (Block_header.shell_header.level
              (Alpha_context.Block_header.t.shell bh2)))
          (Pervasives.not ((|Block_hash|).(S.HASH.equal) hash1 hash2)))
        extensible_type_value)
      (fun function_parameter =>
        let '_ := function_parameter in
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Raw_level.of_int32
              (Block_header.shell_header.level
                (Alpha_context.Block_header.t.shell bh1))))
          (fun raw_level =>
            let oldest_level := Alpha_context.Level.last_allowed_fork_level ctxt
              in
            Error_monad.op_gtgteqquestion
              (Error_monad.fail_unless
                (Alpha_context.Raw_level.op_lt raw_level
                  (Alpha_context.Level.t.level
                    (Alpha_context.Level.current ctxt))) extensible_type_value)
              (fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Error_monad.fail_unless
                    (Alpha_context.Raw_level.op_lteq oldest_level raw_level)
                    extensible_type_value)
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    let level :=
                      Alpha_context.Level.from_raw ctxt None raw_level in
                    Error_monad.op_gtgteqquestion
                      (Alpha_context.Roll.baking_rights_owner ctxt level
                        (Alpha_context.Block_header.contents.priority
                          (Alpha_context.Block_header.protocol_data.contents
                            (Alpha_context.Block_header.t.protocol_data bh1))))
                      (fun delegate1 =>
                        Error_monad.op_gtgteqquestion
                          (Baking.check_signature bh1 chain_id delegate1)
                          (fun function_parameter =>
                            let '_ := function_parameter in
                            Error_monad.op_gtgteqquestion
                              (Alpha_context.Roll.baking_rights_owner ctxt level
                                (Alpha_context.Block_header.contents.priority
                                  (Alpha_context.Block_header.protocol_data.contents
                                    (Alpha_context.Block_header.t.protocol_data
                                      bh2))))
                              (fun delegate2 =>
                                Error_monad.op_gtgteqquestion
                                  (Baking.check_signature bh2 chain_id delegate2)
                                  (fun function_parameter =>
                                    let '_ := function_parameter in
                                    Error_monad.op_gtgteqquestion
                                      (Error_monad.fail_unless
                                        ((|Signature.Public_key|).(S.SPublic_key.equal)
                                          delegate1 delegate2)
                                        extensible_type_value)
                                      (fun function_parameter =>
                                        let '_ := function_parameter in
                                        let delegate :=
                                          (|Signature.Public_key|).(S.SPublic_key.__hash_value)
                                            delegate1 in
                                        Error_monad.op_gtgteqquestion
                                          (Alpha_context.Delegate.has_frozen_balance
                                            ctxt delegate
                                            (Alpha_context.Level.t.cycle level))
                                          (fun valid =>
                                            Error_monad.op_gtgteqquestion
                                              (Error_monad.fail_unless valid
                                                extensible_type_value)
                                              (fun function_parameter =>
                                                let '_ := function_parameter in
                                                Error_monad.op_gtgteqquestion
                                                  (Alpha_context.Delegate.punish
                                                    ctxt delegate
                                                    (Alpha_context.Level.t.cycle
                                                      level))
                                                  (fun function_parameter =>
                                                    let '(ctxt, balance) :=
                                                      function_parameter in
                                                    Error_monad.op_gtgteqquestion
                                                      (Lwt.__return
                                                        (Alpha_context.Tez.op_plusquestion
                                                          (Alpha_context.Delegate.frozen_balance.deposit
                                                            balance)
                                                          (Alpha_context.Delegate.frozen_balance.fees
                                                            balance)))
                                                      (fun burned =>
                                                        let reward :=
                                                          match
                                                            Alpha_context.Tez.op_divquestion
                                                              burned
                                                              (* ❌ Constant of type int64 is converted to int *)
                                                              2 with
                                                          | Pervasives.Ok v => v
                                                          | Pervasives.Error _
                                                            =>
                                                            Alpha_context.Tez.zero
                                                          end in
                                                        Error_monad.op_gtgteqquestion
                                                          (Alpha_context.add_rewards
                                                            ctxt reward)
                                                          (fun ctxt =>
                                                            let current_cycle :=
                                                              Alpha_context.Level.t.cycle
                                                                (Alpha_context.Level.current
                                                                  ctxt) in
                                                            Error_monad.__return
                                                              (ctxt,
                                                                (Apply_results.Single_result
                                                                  (Apply_results.Double_baking_evidence_result
                                                                    (Alpha_context.Delegate.cleanup_balance_updates
                                                                      [
                                                                        ((Alpha_context.Delegate.Deposits
                                                                          delegate
                                                                          (Alpha_context.Level.t.cycle
                                                                            level)),
                                                                          (Alpha_context.Delegate.Debited
                                                                            (Alpha_context.Delegate.frozen_balance.deposit
                                                                              balance)));
                                                                        ((Alpha_context.Delegate.Fees
                                                                          delegate
                                                                          (Alpha_context.Level.t.cycle
                                                                            level)),
                                                                          (Alpha_context.Delegate.Debited
                                                                            (Alpha_context.Delegate.frozen_balance.fees
                                                                              balance)));
                                                                        ((Alpha_context.Delegate.Rewards
                                                                          delegate
                                                                          (Alpha_context.Level.t.cycle
                                                                            level)),
                                                                          (Alpha_context.Delegate.Debited
                                                                            (Alpha_context.Delegate.frozen_balance.rewards
                                                                              balance)));
                                                                        ((Alpha_context.Delegate.Rewards
                                                                          baker
                                                                          current_cycle),
                                                                          (Alpha_context.Delegate.Credited
                                                                            reward))
                                                                      ]))))))))))))))))))
  |
    Alpha_context.Single
      (Alpha_context.Activate_account {|
        Alpha_context.contents.Activate_account.id := pkh;
          Alpha_context.contents.Activate_account.activation_code :=
            activation_code
          |}) =>
    let blinded_pkh :=
      Blinded_public_key_hash.of_ed25519_pkh activation_code pkh in
    Error_monad.op_gtgteqquestion
      (Alpha_context.Commitment.get_opt ctxt blinded_pkh)
      (fun function_parameter =>
        match function_parameter with
        | None => Error_monad.fail extensible_type_value
        | Some amount =>
          Error_monad.op_gtgteqquestion
            (Alpha_context.Commitment.delete ctxt blinded_pkh)
            (fun ctxt =>
              let contract :=
                Alpha_context.Contract.implicit_contract
                  (Signature.Ed25519Hash pkh) in
              Error_monad.op_gtgteqquestion
                (Alpha_context.Contract.credit ctxt contract amount)
                (fun ctxt =>
                  Error_monad.__return
                    (ctxt,
                      (Apply_results.Single_result
                        (Apply_results.Activate_account_result
                          [
                            ((Alpha_context.Delegate.Contract contract),
                              (Alpha_context.Delegate.Credited
                                amount))
                          ])))))
        end)
  |
    Alpha_context.Single
      (Alpha_context.Proposals {|
        Alpha_context.contents.Proposals.source := source;
          Alpha_context.contents.Proposals.period := period;
          Alpha_context.contents.Proposals.proposals := proposals
          |}) =>
    Error_monad.op_gtgteqquestion
      (Alpha_context.Roll.delegate_pubkey ctxt source)
      (fun delegate =>
        Error_monad.op_gtgteqquestion
          (Alpha_context.Operation.check_signature delegate chain_id operation)
          (fun function_parameter =>
            let '_ := function_parameter in
            let level := Alpha_context.Level.current ctxt in
            Error_monad.op_gtgteqquestion
              (Error_monad.fail_unless
                (Alpha_context.Voting_period.op_eq
                  (Alpha_context.Level.t.voting_period level) period)
                extensible_type_value)
              (fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Amendment.record_proposals ctxt source proposals)
                  (fun ctxt =>
                    Error_monad.__return
                      (ctxt,
                        (Apply_results.Single_result
                          Apply_results.Proposals_result))))))
  |
    Alpha_context.Single
      (Alpha_context.Ballot {|
        Alpha_context.contents.Ballot.source := source;
          Alpha_context.contents.Ballot.period := period;
          Alpha_context.contents.Ballot.proposal := proposal;
          Alpha_context.contents.Ballot.ballot := ballot
          |}) =>
    Error_monad.op_gtgteqquestion
      (Alpha_context.Roll.delegate_pubkey ctxt source)
      (fun delegate =>
        Error_monad.op_gtgteqquestion
          (Alpha_context.Operation.check_signature delegate chain_id operation)
          (fun function_parameter =>
            let '_ := function_parameter in
            let level := Alpha_context.Level.current ctxt in
            Error_monad.op_gtgteqquestion
              (Error_monad.fail_unless
                (Alpha_context.Voting_period.op_eq
                  (Alpha_context.Level.t.voting_period level) period)
                extensible_type_value)
              (fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Amendment.record_ballot ctxt source proposal ballot)
                  (fun ctxt =>
                    Error_monad.__return
                      (ctxt,
                        (Apply_results.Single_result Apply_results.Ballot_result))))))
  | (Alpha_context.Single (Alpha_context.Manager_operation _)) as op =>
    Error_monad.op_gtgteqquestion
      (precheck_manager_contents_list ctxt chain_id operation op)
      (fun ctxt =>
        Error_monad.op_gtgteq
          (apply_manager_contents_list ctxt mode baker chain_id op)
          (fun function_parameter =>
            let '(ctxt, __result_value) := function_parameter in
            Error_monad.__return (ctxt, __result_value)))
  | (Alpha_context.Cons (Alpha_context.Manager_operation _) _) as op =>
    Error_monad.op_gtgteqquestion
      (precheck_manager_contents_list ctxt chain_id operation op)
      (fun ctxt =>
        Error_monad.op_gtgteq
          (apply_manager_contents_list ctxt mode baker chain_id op)
          (fun function_parameter =>
            let '(ctxt, __result_value) := function_parameter in
            Error_monad.__return (ctxt, __result_value)))
  end.

Definition apply_operation {A : Set}
  (ctxt : Alpha_context.context) (chain_id : (|Chain_id|).(S.HASH.t))
  (mode : Script_ir_translator.unparsing_mode)
  (pred_block : (|Block_hash|).(S.HASH.t))
  (baker : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (__hash_value : (|Operation_hash|).(S.HASH.t))
  (operation : Alpha_context.operation A)
  : Lwt.t
    (Error_monad.tzresult
      (Alpha_context.context * Apply_results.operation_metadata A)) :=
  let ctxt := Alpha_context.Contract.init_origination_nonce ctxt __hash_value in
  Error_monad.op_gtgteqquestion
    (apply_contents_list ctxt chain_id mode pred_block baker operation
      (Alpha_context.protocol_data.contents
        (Alpha_context.operation.protocol_data operation)))
    (fun function_parameter =>
      let '(ctxt, __result_value) := function_parameter in
      let ctxt := Alpha_context.Gas.set_unlimited ctxt in
      let ctxt := Alpha_context.Contract.unset_origination_nonce ctxt in
      Error_monad.__return
        (ctxt, {| Apply_results.operation_metadata.contents := __result_value |})).

Definition may_snapshot_roll (ctxt : Alpha_context.context)
  : Lwt.t (Error_monad.tzresult Alpha_context.context) :=
  let level := Alpha_context.Level.current ctxt in
  let blocks_per_roll_snapshot :=
    Alpha_context.Constants.blocks_per_roll_snapshot ctxt in
  if
    (|Compare.Int32|).(Compare.S.equal)
      (Int32.rem (Alpha_context.Level.t.cycle_position level)
        blocks_per_roll_snapshot) (Int32.pred blocks_per_roll_snapshot) then
    Error_monad.op_gtgteqquestion (Alpha_context.Roll.snapshot_rolls ctxt)
      (fun ctxt => Error_monad.__return ctxt)
  else
    Error_monad.__return ctxt.

Definition may_start_new_cycle (ctxt : Alpha_context.context)
  : Lwt.t
    (Error_monad.tzresult
      (Alpha_context.context * Alpha_context.Delegate.balance_updates *
        list (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))) :=
  Error_monad.op_gtgteqquestion (Baking.dawn_of_a_new_cycle ctxt)
    (fun function_parameter =>
      match function_parameter with
      | None => Error_monad.__return (ctxt, [], [])
      | Some last_cycle =>
        Error_monad.op_gtgteqquestion
          (Alpha_context.Seed.cycle_end ctxt last_cycle)
          (fun function_parameter =>
            let '(ctxt, unrevealed) := function_parameter in
            Error_monad.op_gtgteqquestion
              (Alpha_context.Roll.cycle_end ctxt last_cycle)
              (fun ctxt =>
                Error_monad.op_gtgteqquestion
                  (Alpha_context.Delegate.cycle_end ctxt last_cycle unrevealed)
                  (fun function_parameter =>
                    let '(ctxt, update_balances, deactivated) :=
                      function_parameter in
                    Error_monad.op_gtgteqquestion
                      (Alpha_context.Bootstrap.cycle_end ctxt last_cycle)
                      (fun ctxt =>
                        Error_monad.__return
                          (ctxt, update_balances, deactivated)))))
      end).

Definition begin_full_construction
  (ctxt : Alpha_context.context) (pred_timestamp : Time.t)
  (protocol_data : Alpha_context.Block_header.contents)
  : Lwt.t
    (Error_monad.tzresult
      (Alpha_context.context * Alpha_context.Block_header.contents *
        Alpha_context.public_key * Alpha_context.Period.t)) :=
  Error_monad.op_gtgteqquestion
    (Alpha_context.Global.set_block_priority ctxt
      (Alpha_context.Block_header.contents.priority protocol_data))
    (fun ctxt =>
      Error_monad.op_gtgteqquestion
        (Baking.check_baking_rights ctxt protocol_data pred_timestamp)
        (fun function_parameter =>
          let '(delegate_pk, block_delay) := function_parameter in
          let ctxt := Alpha_context.Fitness.increase None ctxt in
          match Alpha_context.Level.pred ctxt (Alpha_context.Level.current ctxt)
            with
          | None =>
            (* ❌ Assert instruction is not handled. *)
            assert false
          | Some pred_level =>
            Error_monad.op_gtgteqquestion
              (Baking.endorsement_rights ctxt pred_level)
              (fun rights =>
                let ctxt := Alpha_context.init_endorsements ctxt rights in
                Error_monad.__return
                  (ctxt, protocol_data, delegate_pk, block_delay))
          end)).

Definition begin_partial_construction (ctxt : Alpha_context.context)
  : Lwt.t (Error_monad.tzresult Alpha_context.context) :=
  let ctxt := Alpha_context.Fitness.increase None ctxt in
  match Alpha_context.Level.pred ctxt (Alpha_context.Level.current ctxt) with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some pred_level =>
    Error_monad.op_gtgteqquestion (Baking.endorsement_rights ctxt pred_level)
      (fun rights =>
        let ctxt := Alpha_context.init_endorsements ctxt rights in
        Error_monad.__return ctxt)
  end.

Definition begin_application
  (ctxt : Alpha_context.context) (chain_id : (|Chain_id|).(S.HASH.t))
  (block_header : Alpha_context.Block_header.t) (pred_timestamp : Time.t)
  : Lwt.t
    (Error_monad.tzresult
      (Alpha_context.context * Alpha_context.public_key * Alpha_context.Period.t)) :=
  Error_monad.op_gtgteqquestion
    (Alpha_context.Global.set_block_priority ctxt
      (Alpha_context.Block_header.contents.priority
        (Alpha_context.Block_header.protocol_data.contents
          (Alpha_context.Block_header.t.protocol_data block_header))))
    (fun ctxt =>
      let current_level := Alpha_context.Level.current ctxt in
      Error_monad.op_gtgteqquestion
        (Baking.check_proof_of_work_stamp ctxt block_header)
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgteqquestion
            (Baking.check_fitness_gap ctxt block_header)
            (fun function_parameter =>
              let '_ := function_parameter in
              Error_monad.op_gtgteqquestion
                (Baking.check_baking_rights ctxt
                  (Alpha_context.Block_header.protocol_data.contents
                    (Alpha_context.Block_header.t.protocol_data block_header))
                  pred_timestamp)
                (fun function_parameter =>
                  let '(delegate_pk, block_delay) := function_parameter in
                  Error_monad.op_gtgteqquestion
                    (Baking.check_signature block_header chain_id delegate_pk)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      let has_commitment :=
                        match
                          Alpha_context.Block_header.contents.seed_nonce_hash
                            (Alpha_context.Block_header.protocol_data.contents
                              (Alpha_context.Block_header.t.protocol_data
                                block_header)) with
                        | None => false
                        | Some _ => true
                        end in
                      Error_monad.op_gtgteqquestion
                        (Error_monad.fail_unless
                          ((|Compare.Bool|).(Compare.S.op_eq) has_commitment
                            (Alpha_context.Level.t.expected_commitment
                              current_level)) extensible_type_value)
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          let ctxt := Alpha_context.Fitness.increase None ctxt
                            in
                          match
                            Alpha_context.Level.pred ctxt
                              (Alpha_context.Level.current ctxt) with
                          | None =>
                            (* ❌ Assert instruction is not handled. *)
                            assert false
                          | Some pred_level =>
                            Error_monad.op_gtgteqquestion
                              (Baking.endorsement_rights ctxt pred_level)
                              (fun rights =>
                                let ctxt :=
                                  Alpha_context.init_endorsements ctxt rights in
                                Error_monad.__return
                                  (ctxt, delegate_pk, block_delay))
                          end)))))).

Definition check_minimum_endorsements
  (ctxt : Alpha_context.context)
  (protocol_data : Alpha_context.Block_header.contents)
  (block_delay : Alpha_context.Period.t)
  (included_endorsements : (|Compare.Int|).(Compare.S.t))
  : Lwt.t (Error_monad.tzresult unit) :=
  let minimum := Baking.minimum_allowed_endorsements ctxt block_delay in
  let timestamp := Alpha_context.Timestamp.current ctxt in
  Error_monad.fail_unless
    ((|Compare.Int|).(Compare.S.op_gteq) included_endorsements minimum)
    extensible_type_value.

Definition finalize_application
  (ctxt : Alpha_context.context)
  (protocol_data : Alpha_context.Block_header.contents)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (block_delay : Alpha_context.Period.t)
  : Lwt.t
    (Error_monad.tzresult (Alpha_context.context * Apply_results.block_metadata)) :=
  let included_endorsements := Alpha_context.included_endorsements ctxt in
  Error_monad.op_gtgteqquestion
    (check_minimum_endorsements ctxt protocol_data block_delay
      included_endorsements)
    (fun function_parameter =>
      let '_ := function_parameter in
      let deposit := Alpha_context.Constants.block_security_deposit ctxt in
      Error_monad.op_gtgteqquestion
        (Alpha_context.add_deposit ctxt delegate deposit)
        (fun ctxt =>
          Error_monad.op_gtgteqquestion
            (Baking.baking_reward ctxt
              (Alpha_context.Block_header.contents.priority protocol_data)
              included_endorsements)
            (fun reward =>
              Error_monad.op_gtgteqquestion
                (Alpha_context.add_rewards ctxt reward)
                (fun ctxt =>
                  Error_monad.op_gtgteqquestion
                    ((|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.fold)
                      (fun delegate =>
                        fun deposit =>
                          fun ctxt =>
                            Error_monad.op_gtgteqquestion ctxt
                              (fun ctxt =>
                                Alpha_context.Delegate.freeze_deposit ctxt
                                  delegate deposit))
                      (Alpha_context.get_deposits ctxt)
                      (Error_monad.__return ctxt))
                    (fun ctxt =>
                      let fees := Alpha_context.get_fees ctxt in
                      Error_monad.op_gtgteqquestion
                        (Alpha_context.Delegate.freeze_fees ctxt delegate fees)
                        (fun ctxt =>
                          let rewards := Alpha_context.get_rewards ctxt in
                          Error_monad.op_gtgteqquestion
                            (Alpha_context.Delegate.freeze_rewards ctxt delegate
                              rewards)
                            (fun ctxt =>
                              Error_monad.op_gtgteqquestion
                                match
                                  Alpha_context.Block_header.contents.seed_nonce_hash
                                    protocol_data with
                                | None => Error_monad.__return ctxt
                                | Some nonce_hash =>
                                  Alpha_context.Nonce.record_hash ctxt
                                    {|
                                      Alpha_context.Nonce.unrevealed.nonce_hash :=
                                        nonce_hash;
                                      Alpha_context.Nonce.unrevealed.delegate :=
                                        delegate;
                                      Alpha_context.Nonce.unrevealed.rewards :=
                                        rewards;
                                      Alpha_context.Nonce.unrevealed.fees :=
                                        fees |}
                                end
                                (fun ctxt =>
                                  Error_monad.op_gtgteqquestion
                                    (may_snapshot_roll ctxt)
                                    (fun ctxt =>
                                      Error_monad.op_gtgteqquestion
                                        (may_start_new_cycle ctxt)
                                        (fun function_parameter =>
                                          let
                                            '(ctxt, balance_updates, deactivated) :=
                                            function_parameter in
                                          Error_monad.op_gtgteqquestion
                                            (Amendment.may_start_new_voting_period
                                              ctxt)
                                            (fun ctxt =>
                                              let cycle :=
                                                Alpha_context.Level.t.cycle
                                                  (Alpha_context.Level.current
                                                    ctxt) in
                                              let balance_updates :=
                                                Alpha_context.Delegate.cleanup_balance_updates
                                                  (Pervasives.op_at
                                                    [
                                                      ((Alpha_context.Delegate.Contract
                                                        (Alpha_context.Contract.implicit_contract
                                                          delegate)),
                                                        (Alpha_context.Delegate.Debited
                                                          deposit));
                                                      ((Alpha_context.Delegate.Deposits
                                                        delegate
                                                        cycle),
                                                        (Alpha_context.Delegate.Credited
                                                          deposit));
                                                      ((Alpha_context.Delegate.Rewards
                                                        delegate
                                                        cycle),
                                                        (Alpha_context.Delegate.Credited
                                                          reward))
                                                    ] balance_updates) in
                                              let consumed_gas :=
                                                Z.sub
                                                  (Alpha_context.Constants.hard_gas_limit_per_block
                                                    ctxt)
                                                  (Alpha_context.Gas.block_level
                                                    ctxt) in
                                              Error_monad.op_gtgteqquestion
                                                (Alpha_context.Vote.get_current_period_kind
                                                  ctxt)
                                                (fun voting_period_kind =>
                                                  let receipt :=
                                                    {|
                                                      Apply_results.block_metadata.baker :=
                                                        delegate;
                                                      Apply_results.block_metadata.level :=
                                                        Alpha_context.Level.current
                                                          ctxt;
                                                      Apply_results.block_metadata.voting_period_kind :=
                                                        voting_period_kind;
                                                      Apply_results.block_metadata.nonce_hash :=
                                                        Alpha_context.Block_header.contents.seed_nonce_hash
                                                          protocol_data;
                                                      Apply_results.block_metadata.consumed_gas :=
                                                        consumed_gas;
                                                      Apply_results.block_metadata.deactivated :=
                                                        deactivated;
                                                      Apply_results.block_metadata.balance_updates :=
                                                        balance_updates |} in
                                                  Error_monad.__return
                                                    (ctxt, receipt))))))))))))).

Apply_results

  • OCaml size: 1187 lines
  • Coq size: 1897 lines (+59% compared to OCaml)
apply_results.ml 9 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Data_encoding

let error_encoding =
  def
    "error"
    ~description:
      "The full list of RPC errors would be too long to include.\n\
       It is available at RPC `/errors` (GET).\n\
       Errors specific to protocol Alpha have an id that starts with \
       `proto.alpha`."
  @@ splitted
       ~json:
         (conv
            (fun err ->
              Data_encoding.Json.construct Error_monad.error_encoding err)
            (fun json ->
              Data_encoding.Json.destruct Error_monad.error_encoding json)
            json)
       ~binary:Error_monad.error_encoding

type _ successful_manager_operation_result =
  | Reveal_result : {
      consumed_gas : Z.t;
    }
      -> Kind.reveal successful_manager_operation_result
  | Transaction_result : {
      storage : Script.expr option;
      big_map_diff : Contract.big_map_diff option;
      balance_updates : Delegate.balance_updates;
      originated_contracts : Contract.t list;
      consumed_gas : Z.t;
      storage_size : Z.t;
      paid_storage_size_diff : Z.t;
      allocated_destination_contract : bool;
    }
      -> Kind.transaction successful_manager_operation_result
  | Origination_result : {
      big_map_diff : Contract.big_map_diff option;
      balance_updates : Delegate.balance_updates;
      originated_contracts : Contract.t list;
      consumed_gas : Z.t;
      storage_size : Z.t;
      paid_storage_size_diff : Z.t;
    }
      -> Kind.origination successful_manager_operation_result
  | Delegation_result : {
      consumed_gas : Z.t;
    }
      -> Kind.delegation successful_manager_operation_result

type packed_successful_manager_operation_result =
  | Successful_manager_result :
      'kind successful_manager_operation_result
      -> packed_successful_manager_operation_result

type 'kind manager_operation_result =
  | Applied of 'kind successful_manager_operation_result
  | Backtracked of
      'kind successful_manager_operation_result * error list option
  | Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result
  | Skipped : 'kind Kind.manager -> 'kind manager_operation_result

type packed_internal_operation_result =
  | Internal_operation_result :
      'kind internal_operation * 'kind manager_operation_result
      -> packed_internal_operation_result

module Manager_result = struct
  type 'kind case =
    | MCase : {
        op_case : 'kind Operation.Encoding.Manager_operations.case;
        encoding : 'a Data_encoding.t;
        kind : 'kind Kind.manager;
        iselect :
          packed_internal_operation_result ->
          ('kind internal_operation * 'kind manager_operation_result) option;
        select :
          packed_successful_manager_operation_result ->
          'kind successful_manager_operation_result option;
        proj : 'kind successful_manager_operation_result -> 'a;
        inj : 'a -> 'kind successful_manager_operation_result;
        t : 'kind manager_operation_result Data_encoding.t;
      }
        -> 'kind case

  let make ~op_case ~encoding ~kind ~iselect ~select ~proj ~inj =
    let (Operation.Encoding.Manager_operations.MCase {name; _}) = op_case in
    let t =
      def (Format.asprintf "operation.alpha.operation_result.%s" name)
      @@ union
           ~tag_size:`Uint8
           [ case
               (Tag 0)
               ~title:"Applied"
               (merge_objs (obj1 (req "status" (constant "applied"))) encoding)
               (fun o ->
                 match o with
                 | Skipped _ | Failed _ | Backtracked _ ->
                     None
                 | Applied o -> (
                   match select (Successful_manager_result o) with
                   | None ->
                       None
                   | Some o ->
                       Some ((), proj o) ))
               (fun ((), x) -> Applied (inj x));
             case
               (Tag 1)
               ~title:"Failed"
               (obj2
                  (req "status" (constant "failed"))
                  (req "errors" (list error_encoding)))
               (function Failed (_, errs) -> Some ((), errs) | _ -> None)
               (fun ((), errs) -> Failed (kind, errs));
             case
               (Tag 2)
               ~title:"Skipped"
               (obj1 (req "status" (constant "skipped")))
               (function Skipped _ -> Some () | _ -> None)
               (fun () -> Skipped kind);
             case
               (Tag 3)
               ~title:"Backtracked"
               (merge_objs
                  (obj2
                     (req "status" (constant "backtracked"))
                     (opt "errors" (list error_encoding)))
                  encoding)
               (fun o ->
                 match o with
                 | Skipped _ | Failed _ | Applied _ ->
                     None
                 | Backtracked (o, errs) -> (
                   match select (Successful_manager_result o) with
                   | None ->
                       None
                   | Some o ->
                       Some (((), errs), proj o) ))
               (fun (((), errs), x) -> Backtracked (inj x, errs)) ]
    in
    MCase {op_case; encoding; kind; iselect; select; proj; inj; t}

  let reveal_case =
    make
      ~op_case:Operation.Encoding.Manager_operations.reveal_case
      ~encoding:Data_encoding.(obj1 (dft "consumed_gas" z Z.zero))
      ~iselect:(function
        | Internal_operation_result (({operation = Reveal _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)
      ~select:(function
        | Successful_manager_result (Reveal_result _ as op) ->
            Some op
        | _ ->
            None)
      ~kind:Kind.Reveal_manager_kind
      ~proj:(function Reveal_result {consumed_gas} -> consumed_gas)
      ~inj:(fun consumed_gas -> Reveal_result {consumed_gas})

  let transaction_case =
    make
      ~op_case:Operation.Encoding.Manager_operations.transaction_case
      ~encoding:
        (obj8
           (opt "storage" Script.expr_encoding)
           (opt "big_map_diff" Contract.big_map_diff_encoding)
           (dft "balance_updates" Delegate.balance_updates_encoding [])
           (dft "originated_contracts" (list Contract.encoding) [])
           (dft "consumed_gas" z Z.zero)
           (dft "storage_size" z Z.zero)
           (dft "paid_storage_size_diff" z Z.zero)
           (dft "allocated_destination_contract" bool false))
      ~iselect:(function
        | Internal_operation_result
            (({operation = Transaction _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)
      ~select:(function
        | Successful_manager_result (Transaction_result _ as op) ->
            Some op
        | _ ->
            None)
      ~kind:Kind.Transaction_manager_kind
      ~proj:(function
        | Transaction_result
            { storage;
              big_map_diff;
              balance_updates;
              originated_contracts;
              consumed_gas;
              storage_size;
              paid_storage_size_diff;
              allocated_destination_contract } ->
            ( storage,
              big_map_diff,
              balance_updates,
              originated_contracts,
              consumed_gas,
              storage_size,
              paid_storage_size_diff,
              allocated_destination_contract ))
      ~inj:
        (fun ( storage,
               big_map_diff,
               balance_updates,
               originated_contracts,
               consumed_gas,
               storage_size,
               paid_storage_size_diff,
               allocated_destination_contract ) ->
        Transaction_result
          {
            storage;
            big_map_diff;
            balance_updates;
            originated_contracts;
            consumed_gas;
            storage_size;
            paid_storage_size_diff;
            allocated_destination_contract;
          })

  let origination_case =
    make
      ~op_case:Operation.Encoding.Manager_operations.origination_case
      ~encoding:
        (obj6
           (opt "big_map_diff" Contract.big_map_diff_encoding)
           (dft "balance_updates" Delegate.balance_updates_encoding [])
           (dft "originated_contracts" (list Contract.encoding) [])
           (dft "consumed_gas" z Z.zero)
           (dft "storage_size" z Z.zero)
           (dft "paid_storage_size_diff" z Z.zero))
      ~iselect:(function
        | Internal_operation_result
            (({operation = Origination _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)
      ~select:(function
        | Successful_manager_result (Origination_result _ as op) ->
            Some op
        | _ ->
            None)
      ~proj:(function
        | Origination_result
            { big_map_diff;
              balance_updates;
              originated_contracts;
              consumed_gas;
              storage_size;
              paid_storage_size_diff } ->
            ( big_map_diff,
              balance_updates,
              originated_contracts,
              consumed_gas,
              storage_size,
              paid_storage_size_diff ))
      ~kind:Kind.Origination_manager_kind
      ~inj:
        (fun ( big_map_diff,
               balance_updates,
               originated_contracts,
               consumed_gas,
               storage_size,
               paid_storage_size_diff ) ->
        Origination_result
          {
            big_map_diff;
            balance_updates;
            originated_contracts;
            consumed_gas;
            storage_size;
            paid_storage_size_diff;
          })

  let delegation_case =
    make
      ~op_case:Operation.Encoding.Manager_operations.delegation_case
      ~encoding:Data_encoding.(obj1 (dft "consumed_gas" z Z.zero))
      ~iselect:(function
        | Internal_operation_result (({operation = Delegation _; _} as op), res)
          ->
            Some (op, res)
        | _ ->
            None)
      ~select:(function
        | Successful_manager_result (Delegation_result _ as op) ->
            Some op
        | _ ->
            None)
      ~kind:Kind.Delegation_manager_kind
      ~proj:(function Delegation_result {consumed_gas} -> consumed_gas)
      ~inj:(fun consumed_gas -> Delegation_result {consumed_gas})
end

let internal_operation_result_encoding :
    packed_internal_operation_result Data_encoding.t =
  let make (type kind)
      (Manager_result.MCase res_case : kind Manager_result.case) =
    let (Operation.Encoding.Manager_operations.MCase op_case) =
      res_case.op_case
    in
    case
      (Tag op_case.tag)
      ~title:op_case.name
      (merge_objs
         (obj3
            (req "kind" (constant op_case.name))
            (req "source" Contract.encoding)
            (req "nonce" uint16))
         (merge_objs op_case.encoding (obj1 (req "result" res_case.t))))
      (fun op ->
        match res_case.iselect op with
        | Some (op, res) ->
            Some (((), op.source, op.nonce), (op_case.proj op.operation, res))
        | None ->
            None)
      (fun (((), source, nonce), (op, res)) ->
        let op = {source; operation = op_case.inj op; nonce} in
        Internal_operation_result (op, res))
  in
  def "operation.alpha.internal_operation_result"
  @@ union
       [ make Manager_result.reveal_case;
         make Manager_result.transaction_case;
         make Manager_result.origination_case;
         make Manager_result.delegation_case ]

type 'kind contents_result =
  | Endorsement_result : {
      balance_updates : Delegate.balance_updates;
      delegate : Signature.Public_key_hash.t;
      slots : int list;
    }
      -> Kind.endorsement contents_result
  | Seed_nonce_revelation_result :
      Delegate.balance_updates
      -> Kind.seed_nonce_revelation contents_result
  | Double_endorsement_evidence_result :
      Delegate.balance_updates
      -> Kind.double_endorsement_evidence contents_result
  | Double_baking_evidence_result :
      Delegate.balance_updates
      -> Kind.double_baking_evidence contents_result
  | Activate_account_result :
      Delegate.balance_updates
      -> Kind.activate_account contents_result
  | Proposals_result : Kind.proposals contents_result
  | Ballot_result : Kind.ballot contents_result
  | Manager_operation_result : {
      balance_updates : Delegate.balance_updates;
      operation_result : 'kind manager_operation_result;
      internal_operation_results : packed_internal_operation_result list;
    }
      -> 'kind Kind.manager contents_result

type packed_contents_result =
  | Contents_result : 'kind contents_result -> packed_contents_result

type packed_contents_and_result =
  | Contents_and_result :
      'kind Operation.contents * 'kind contents_result
      -> packed_contents_and_result

type ('a, 'b) eq = Eq : ('a, 'a) eq

let equal_manager_kind :
    type a b. a Kind.manager -> b Kind.manager -> (a, b) eq option =
 fun ka kb ->
  match (ka, kb) with
  | (Kind.Reveal_manager_kind, Kind.Reveal_manager_kind) ->
      Some Eq
  | (Kind.Reveal_manager_kind, _) ->
      None
  | (Kind.Transaction_manager_kind, Kind.Transaction_manager_kind) ->
      Some Eq
  | (Kind.Transaction_manager_kind, _) ->
      None
  | (Kind.Origination_manager_kind, Kind.Origination_manager_kind) ->
      Some Eq
  | (Kind.Origination_manager_kind, _) ->
      None
  | (Kind.Delegation_manager_kind, Kind.Delegation_manager_kind) ->
      Some Eq
  | (Kind.Delegation_manager_kind, _) ->
      None

module Encoding = struct
  type 'kind case =
    | Case : {
        op_case : 'kind Operation.Encoding.case;
        encoding : 'a Data_encoding.t;
        select : packed_contents_result -> 'kind contents_result option;
        mselect :
          packed_contents_and_result ->
          ('kind contents * 'kind contents_result) option;
        proj : 'kind contents_result -> 'a;
        inj : 'a -> 'kind contents_result;
      }
        -> 'kind case

  let tagged_case tag name args proj inj =
    let open Data_encoding in
    case
      tag
      ~title:(String.capitalize_ascii name)
      (merge_objs (obj1 (req "kind" (constant name))) args)
      (fun x -> match proj x with None -> None | Some x -> Some ((), x))
      (fun ((), x) -> inj x)

  let endorsement_case =
    Case
      {
        op_case = Operation.Encoding.endorsement_case;
        encoding =
          obj3
            (req "balance_updates" Delegate.balance_updates_encoding)
            (req "delegate" Signature.Public_key_hash.encoding)
            (req "slots" (list uint8));
        select =
          (function
          | Contents_result (Endorsement_result _ as op) -> Some op | _ -> None);
        mselect =
          (function
          | Contents_and_result ((Endorsement _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj =
          (function
          | Endorsement_result {balance_updates; delegate; slots} ->
              (balance_updates, delegate, slots));
        inj =
          (fun (balance_updates, delegate, slots) ->
            Endorsement_result {balance_updates; delegate; slots});
      }

  let seed_nonce_revelation_case =
    Case
      {
        op_case = Operation.Encoding.seed_nonce_revelation_case;
        encoding =
          obj1 (req "balance_updates" Delegate.balance_updates_encoding);
        select =
          (function
          | Contents_result (Seed_nonce_revelation_result _ as op) ->
              Some op
          | _ ->
              None);
        mselect =
          (function
          | Contents_and_result ((Seed_nonce_revelation _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun (Seed_nonce_revelation_result bus) -> bus);
        inj = (fun bus -> Seed_nonce_revelation_result bus);
      }

  let double_endorsement_evidence_case =
    Case
      {
        op_case = Operation.Encoding.double_endorsement_evidence_case;
        encoding =
          obj1 (req "balance_updates" Delegate.balance_updates_encoding);
        select =
          (function
          | Contents_result (Double_endorsement_evidence_result _ as op) ->
              Some op
          | _ ->
              None);
        mselect =
          (function
          | Contents_and_result ((Double_endorsement_evidence _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun (Double_endorsement_evidence_result bus) -> bus);
        inj = (fun bus -> Double_endorsement_evidence_result bus);
      }

  let double_baking_evidence_case =
    Case
      {
        op_case = Operation.Encoding.double_baking_evidence_case;
        encoding =
          obj1 (req "balance_updates" Delegate.balance_updates_encoding);
        select =
          (function
          | Contents_result (Double_baking_evidence_result _ as op) ->
              Some op
          | _ ->
              None);
        mselect =
          (function
          | Contents_and_result ((Double_baking_evidence _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun (Double_baking_evidence_result bus) -> bus);
        inj = (fun bus -> Double_baking_evidence_result bus);
      }

  let activate_account_case =
    Case
      {
        op_case = Operation.Encoding.activate_account_case;
        encoding =
          obj1 (req "balance_updates" Delegate.balance_updates_encoding);
        select =
          (function
          | Contents_result (Activate_account_result _ as op) ->
              Some op
          | _ ->
              None);
        mselect =
          (function
          | Contents_and_result ((Activate_account _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun (Activate_account_result bus) -> bus);
        inj = (fun bus -> Activate_account_result bus);
      }

  let proposals_case =
    Case
      {
        op_case = Operation.Encoding.proposals_case;
        encoding = Data_encoding.empty;
        select =
          (function
          | Contents_result (Proposals_result as op) -> Some op | _ -> None);
        mselect =
          (function
          | Contents_and_result ((Proposals _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun Proposals_result -> ());
        inj = (fun () -> Proposals_result);
      }

  let ballot_case =
    Case
      {
        op_case = Operation.Encoding.ballot_case;
        encoding = Data_encoding.empty;
        select =
          (function
          | Contents_result (Ballot_result as op) -> Some op | _ -> None);
        mselect =
          (function
          | Contents_and_result ((Ballot _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun Ballot_result -> ());
        inj = (fun () -> Ballot_result);
      }

  let make_manager_case (type kind)
      (Operation.Encoding.Case op_case :
        kind Kind.manager Operation.Encoding.case)
      (Manager_result.MCase res_case : kind Manager_result.case) mselect =
    Case
      {
        op_case = Operation.Encoding.Case op_case;
        encoding =
          obj3
            (req "balance_updates" Delegate.balance_updates_encoding)
            (req "operation_result" res_case.t)
            (dft
               "internal_operation_results"
               (list internal_operation_result_encoding)
               []);
        select =
          (function
          | Contents_result
              (Manager_operation_result
                ({operation_result = Applied res; _} as op)) -> (
            match res_case.select (Successful_manager_result res) with
            | Some res ->
                Some
                  (Manager_operation_result
                     {op with operation_result = Applied res})
            | None ->
                None )
          | Contents_result
              (Manager_operation_result
                ({operation_result = Backtracked (res, errs); _} as op)) -> (
            match res_case.select (Successful_manager_result res) with
            | Some res ->
                Some
                  (Manager_operation_result
                     {op with operation_result = Backtracked (res, errs)})
            | None ->
                None )
          | Contents_result
              (Manager_operation_result
                ({operation_result = Skipped kind; _} as op)) -> (
            match equal_manager_kind kind res_case.kind with
            | None ->
                None
            | Some Eq ->
                Some
                  (Manager_operation_result
                     {op with operation_result = Skipped kind}) )
          | Contents_result
              (Manager_operation_result
                ({operation_result = Failed (kind, errs); _} as op)) -> (
            match equal_manager_kind kind res_case.kind with
            | None ->
                None
            | Some Eq ->
                Some
                  (Manager_operation_result
                     {op with operation_result = Failed (kind, errs)}) )
          | Contents_result Ballot_result ->
              None
          | Contents_result (Endorsement_result _) ->
              None
          | Contents_result (Seed_nonce_revelation_result _) ->
              None
          | Contents_result (Double_endorsement_evidence_result _) ->
              None
          | Contents_result (Double_baking_evidence_result _) ->
              None
          | Contents_result (Activate_account_result _) ->
              None
          | Contents_result Proposals_result ->
              None);
        mselect;
        proj =
          (fun (Manager_operation_result
                 { balance_updates = bus;
                   operation_result = r;
                   internal_operation_results = rs }) ->
            (bus, r, rs));
        inj =
          (fun (bus, r, rs) ->
            Manager_operation_result
              {
                balance_updates = bus;
                operation_result = r;
                internal_operation_results = rs;
              });
      }

  let reveal_case =
    make_manager_case
      Operation.Encoding.reveal_case
      Manager_result.reveal_case
      (function
        | Contents_and_result
            ((Manager_operation {operation = Reveal _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)

  let transaction_case =
    make_manager_case
      Operation.Encoding.transaction_case
      Manager_result.transaction_case
      (function
        | Contents_and_result
            ((Manager_operation {operation = Transaction _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)

  let origination_case =
    make_manager_case
      Operation.Encoding.origination_case
      Manager_result.origination_case
      (function
        | Contents_and_result
            ((Manager_operation {operation = Origination _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)

  let delegation_case =
    make_manager_case
      Operation.Encoding.delegation_case
      Manager_result.delegation_case
      (function
        | Contents_and_result
            ((Manager_operation {operation = Delegation _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)
end

let contents_result_encoding =
  let open Encoding in
  let make
      (Case
        { op_case = Operation.Encoding.Case {tag; name; _};
          encoding;
          mselect = _;
          select;
          proj;
          inj }) =
    let proj x =
      match select x with None -> None | Some x -> Some (proj x)
    in
    let inj x = Contents_result (inj x) in
    tagged_case (Tag tag) name encoding proj inj
  in
  def "operation.alpha.contents_result"
  @@ union
       [ make endorsement_case;
         make seed_nonce_revelation_case;
         make double_endorsement_evidence_case;
         make double_baking_evidence_case;
         make activate_account_case;
         make proposals_case;
         make ballot_case;
         make reveal_case;
         make transaction_case;
         make origination_case;
         make delegation_case ]

let contents_and_result_encoding =
  let open Encoding in
  let make
      (Case
        { op_case = Operation.Encoding.Case {tag; name; encoding; proj; inj; _};
          mselect;
          encoding = meta_encoding;
          proj = meta_proj;
          inj = meta_inj;
          _ }) =
    let proj c =
      match mselect c with
      | Some (op, res) ->
          Some (proj op, meta_proj res)
      | _ ->
          None
    in
    let inj (op, res) = Contents_and_result (inj op, meta_inj res) in
    let encoding = merge_objs encoding (obj1 (req "metadata" meta_encoding)) in
    tagged_case (Tag tag) name encoding proj inj
  in
  def "operation.alpha.operation_contents_and_result"
  @@ union
       [ make endorsement_case;
         make seed_nonce_revelation_case;
         make double_endorsement_evidence_case;
         make double_baking_evidence_case;
         make activate_account_case;
         make proposals_case;
         make ballot_case;
         make reveal_case;
         make transaction_case;
         make origination_case;
         make delegation_case ]

type 'kind contents_result_list =
  | Single_result : 'kind contents_result -> 'kind contents_result_list
  | Cons_result :
      'kind Kind.manager contents_result
      * 'rest Kind.manager contents_result_list
      -> ('kind * 'rest) Kind.manager contents_result_list

type packed_contents_result_list =
  | Contents_result_list :
      'kind contents_result_list
      -> packed_contents_result_list

let contents_result_list_encoding =
  let rec to_list = function
    | Contents_result_list (Single_result o) ->
        [Contents_result o]
    | Contents_result_list (Cons_result (o, os)) ->
        Contents_result o :: to_list (Contents_result_list os)
  in
  let rec of_list = function
    | [] ->
        Pervasives.failwith "cannot decode empty operation result"
    | [Contents_result o] ->
        Contents_result_list (Single_result o)
    | Contents_result o :: os -> (
        let (Contents_result_list os) = of_list os in
        match (o, os) with
        | ( Manager_operation_result _,
            Single_result (Manager_operation_result _) ) ->
            Contents_result_list (Cons_result (o, os))
        | (Manager_operation_result _, Cons_result _) ->
            Contents_result_list (Cons_result (o, os))
        | _ ->
            Pervasives.failwith "cannot decode ill-formed operation result" )
  in
  def "operation.alpha.contents_list_result"
  @@ conv to_list of_list (list contents_result_encoding)

type 'kind contents_and_result_list =
  | Single_and_result :
      'kind Alpha_context.contents * 'kind contents_result
      -> 'kind contents_and_result_list
  | Cons_and_result :
      'kind Kind.manager Alpha_context.contents
      * 'kind Kind.manager contents_result
      * 'rest Kind.manager contents_and_result_list
      -> ('kind * 'rest) Kind.manager contents_and_result_list

type packed_contents_and_result_list =
  | Contents_and_result_list :
      'kind contents_and_result_list
      -> packed_contents_and_result_list

let contents_and_result_list_encoding =
  let rec to_list = function
    | Contents_and_result_list (Single_and_result (op, res)) ->
        [Contents_and_result (op, res)]
    | Contents_and_result_list (Cons_and_result (op, res, rest)) ->
        Contents_and_result (op, res)
        :: to_list (Contents_and_result_list rest)
  in
  let rec of_list = function
    | [] ->
        Pervasives.failwith "cannot decode empty combined operation result"
    | [Contents_and_result (op, res)] ->
        Contents_and_result_list (Single_and_result (op, res))
    | Contents_and_result (op, res) :: rest -> (
        let (Contents_and_result_list rest) = of_list rest in
        match (op, rest) with
        | (Manager_operation _, Single_and_result (Manager_operation _, _)) ->
            Contents_and_result_list (Cons_and_result (op, res, rest))
        | (Manager_operation _, Cons_and_result (_, _, _)) ->
            Contents_and_result_list (Cons_and_result (op, res, rest))
        | _ ->
            Pervasives.failwith
              "cannot decode ill-formed combined operation result" )
  in
  conv to_list of_list (Variable.list contents_and_result_encoding)

type 'kind operation_metadata = {contents : 'kind contents_result_list}

type packed_operation_metadata =
  | Operation_metadata : 'kind operation_metadata -> packed_operation_metadata
  | No_operation_metadata : packed_operation_metadata

let operation_metadata_encoding =
  def "operation.alpha.result"
  @@ union
       [ case
           (Tag 0)
           ~title:"Operation_metadata"
           contents_result_list_encoding
           (function
             | Operation_metadata {contents} ->
                 Some (Contents_result_list contents)
             | _ ->
                 None)
           (fun (Contents_result_list contents) ->
             Operation_metadata {contents});
         case
           (Tag 1)
           ~title:"No_operation_metadata"
           empty
           (function No_operation_metadata -> Some () | _ -> None)
           (fun () -> No_operation_metadata) ]

let kind_equal :
    type kind kind2.
    kind contents -> kind2 contents_result -> (kind, kind2) eq option =
 fun op res ->
  match (op, res) with
  | (Endorsement _, Endorsement_result _) ->
      Some Eq
  | (Endorsement _, _) ->
      None
  | (Seed_nonce_revelation _, Seed_nonce_revelation_result _) ->
      Some Eq
  | (Seed_nonce_revelation _, _) ->
      None
  | (Double_endorsement_evidence _, Double_endorsement_evidence_result _) ->
      Some Eq
  | (Double_endorsement_evidence _, _) ->
      None
  | (Double_baking_evidence _, Double_baking_evidence_result _) ->
      Some Eq
  | (Double_baking_evidence _, _) ->
      None
  | (Activate_account _, Activate_account_result _) ->
      Some Eq
  | (Activate_account _, _) ->
      None
  | (Proposals _, Proposals_result) ->
      Some Eq
  | (Proposals _, _) ->
      None
  | (Ballot _, Ballot_result) ->
      Some Eq
  | (Ballot _, _) ->
      None
  | ( Manager_operation {operation = Reveal _; _},
      Manager_operation_result {operation_result = Applied (Reveal_result _); _}
    ) ->
      Some Eq
  | ( Manager_operation {operation = Reveal _; _},
      Manager_operation_result
        {operation_result = Backtracked (Reveal_result _, _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Reveal _; _},
      Manager_operation_result
        { operation_result = Failed (Alpha_context.Kind.Reveal_manager_kind, _);
          _ } ) ->
      Some Eq
  | ( Manager_operation {operation = Reveal _; _},
      Manager_operation_result
        {operation_result = Skipped Alpha_context.Kind.Reveal_manager_kind; _}
    ) ->
      Some Eq
  | (Manager_operation {operation = Reveal _; _}, _) ->
      None
  | ( Manager_operation {operation = Transaction _; _},
      Manager_operation_result
        {operation_result = Applied (Transaction_result _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Transaction _; _},
      Manager_operation_result
        {operation_result = Backtracked (Transaction_result _, _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Transaction _; _},
      Manager_operation_result
        { operation_result =
            Failed (Alpha_context.Kind.Transaction_manager_kind, _);
          _ } ) ->
      Some Eq
  | ( Manager_operation {operation = Transaction _; _},
      Manager_operation_result
        { operation_result = Skipped Alpha_context.Kind.Transaction_manager_kind;
          _ } ) ->
      Some Eq
  | (Manager_operation {operation = Transaction _; _}, _) ->
      None
  | ( Manager_operation {operation = Origination _; _},
      Manager_operation_result
        {operation_result = Applied (Origination_result _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Origination _; _},
      Manager_operation_result
        {operation_result = Backtracked (Origination_result _, _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Origination _; _},
      Manager_operation_result
        { operation_result =
            Failed (Alpha_context.Kind.Origination_manager_kind, _);
          _ } ) ->
      Some Eq
  | ( Manager_operation {operation = Origination _; _},
      Manager_operation_result
        { operation_result = Skipped Alpha_context.Kind.Origination_manager_kind;
          _ } ) ->
      Some Eq
  | (Manager_operation {operation = Origination _; _}, _) ->
      None
  | ( Manager_operation {operation = Delegation _; _},
      Manager_operation_result
        {operation_result = Applied (Delegation_result _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Delegation _; _},
      Manager_operation_result
        {operation_result = Backtracked (Delegation_result _, _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Delegation _; _},
      Manager_operation_result
        { operation_result =
            Failed (Alpha_context.Kind.Delegation_manager_kind, _);
          _ } ) ->
      Some Eq
  | ( Manager_operation {operation = Delegation _; _},
      Manager_operation_result
        { operation_result = Skipped Alpha_context.Kind.Delegation_manager_kind;
          _ } ) ->
      Some Eq
  | (Manager_operation {operation = Delegation _; _}, _) ->
      None

let rec kind_equal_list :
    type kind kind2.
    kind contents_list -> kind2 contents_result_list -> (kind, kind2) eq option
    =
 fun contents res ->
  match (contents, res) with
  | (Single op, Single_result res) -> (
    match kind_equal op res with None -> None | Some Eq -> Some Eq )
  | (Cons (op, ops), Cons_result (res, ress)) -> (
    match kind_equal op res with
    | None ->
        None
    | Some Eq -> (
      match kind_equal_list ops ress with None -> None | Some Eq -> Some Eq ) )
  | _ ->
      None

let rec pack_contents_list :
    type kind.
    kind contents_list ->
    kind contents_result_list ->
    kind contents_and_result_list =
 fun contents res ->
  match (contents, res) with
  | (Single op, Single_result res) ->
      Single_and_result (op, res)
  | (Cons (op, ops), Cons_result (res, ress)) ->
      Cons_and_result (op, res, pack_contents_list ops ress)
  | ( Single (Manager_operation _),
      Cons_result (Manager_operation_result _, Single_result _) ) ->
      .
  | ( Cons (_, _),
      Single_result (Manager_operation_result {operation_result = Failed _; _})
    ) ->
      .
  | ( Cons (_, _),
      Single_result
        (Manager_operation_result {operation_result = Skipped _; _}) ) ->
      .
  | ( Cons (_, _),
      Single_result
        (Manager_operation_result {operation_result = Applied _; _}) ) ->
      .
  | ( Cons (_, _),
      Single_result
        (Manager_operation_result {operation_result = Backtracked _; _}) ) ->
      .
  | (Single _, Cons_result _) ->
      .

let rec unpack_contents_list :
    type kind.
    kind contents_and_result_list ->
    kind contents_list * kind contents_result_list = function
  | Single_and_result (op, res) ->
      (Single op, Single_result res)
  | Cons_and_result (op, res, rest) ->
      let (ops, ress) = unpack_contents_list rest in
      (Cons (op, ops), Cons_result (res, ress))

let rec to_list = function
  | Contents_result_list (Single_result o) ->
      [Contents_result o]
  | Contents_result_list (Cons_result (o, os)) ->
      Contents_result o :: to_list (Contents_result_list os)

let rec of_list = function
  | [] ->
      assert false
  | [Contents_result o] ->
      Contents_result_list (Single_result o)
  | Contents_result o :: os -> (
      let (Contents_result_list os) = of_list os in
      match (o, os) with
      | (Manager_operation_result _, Single_result (Manager_operation_result _))
        ->
          Contents_result_list (Cons_result (o, os))
      | (Manager_operation_result _, Cons_result _) ->
          Contents_result_list (Cons_result (o, os))
      | _ ->
          Pervasives.failwith
            "Operation result list of length > 1 should only contains manager \
             operations result." )

let operation_data_and_metadata_encoding =
  def "operation.alpha.operation_with_metadata"
  @@ union
       [ case
           (Tag 0)
           ~title:"Operation_with_metadata"
           (obj2
              (req "contents" (dynamic_size contents_and_result_list_encoding))
              (opt "signature" Signature.encoding))
           (function
             | (Operation_data _, No_operation_metadata) ->
                 None
             | (Operation_data op, Operation_metadata res) -> (
               match kind_equal_list op.contents res.contents with
               | None ->
                   Pervasives.failwith
                     "cannot decode inconsistent combined operation result"
               | Some Eq ->
                   Some
                     ( Contents_and_result_list
                         (pack_contents_list op.contents res.contents),
                       op.signature ) ))
           (fun (Contents_and_result_list contents, signature) ->
             let (op_contents, res_contents) = unpack_contents_list contents in
             ( Operation_data {contents = op_contents; signature},
               Operation_metadata {contents = res_contents} ));
         case
           (Tag 1)
           ~title:"Operation_without_metadata"
           (obj2
              (req "contents" (dynamic_size Operation.contents_list_encoding))
              (opt "signature" Signature.encoding))
           (function
             | (Operation_data op, No_operation_metadata) ->
                 Some (Contents_list op.contents, op.signature)
             | (Operation_data _, Operation_metadata _) ->
                 None)
           (fun (Contents_list contents, signature) ->
             (Operation_data {contents; signature}, No_operation_metadata)) ]

type block_metadata = {
  baker : Signature.Public_key_hash.t;
  level : Level.t;
  voting_period_kind : Voting_period.kind;
  nonce_hash : Nonce_hash.t option;
  consumed_gas : Z.t;
  deactivated : Signature.Public_key_hash.t list;
  balance_updates : Delegate.balance_updates;
}

let block_metadata_encoding =
  let open Data_encoding in
  def "block_header.alpha.metadata"
  @@ conv
       (fun { baker;
              level;
              voting_period_kind;
              nonce_hash;
              consumed_gas;
              deactivated;
              balance_updates } ->
         ( baker,
           level,
           voting_period_kind,
           nonce_hash,
           consumed_gas,
           deactivated,
           balance_updates ))
       (fun ( baker,
              level,
              voting_period_kind,
              nonce_hash,
              consumed_gas,
              deactivated,
              balance_updates ) ->
         {
           baker;
           level;
           voting_period_kind;
           nonce_hash;
           consumed_gas;
           deactivated;
           balance_updates;
         })
       (obj7
          (req "baker" Signature.Public_key_hash.encoding)
          (req "level" Level.encoding)
          (req "voting_period_kind" Voting_period.kind_encoding)
          (req "nonce_hash" (option Nonce_hash.encoding))
          (req "consumed_gas" (check_size 10 n))
          (req "deactivated" (list Signature.Public_key_hash.encoding))
          (req "balance_updates" Delegate.balance_updates_encoding))
Apply_results.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Nonce_hash.

Import Alpha_context.

Import Data_encoding.

Definition error_encoding : Data_encoding.encoding Error_monad.__error :=
  Pervasives.op_atat
    (let arg :=
      Data_encoding.def "error"
        (* ❌ expected an argument *)
        expected_argument
        (Some
          "The full list of RPC errors would be too long to include.\nIt is available at RPC `/errors` (GET).\nErrors specific to protocol Alpha have an id that starts with `proto.alpha`.")
      in
    fun eta => arg None eta)
    (Data_encoding.splitted
      (Data_encoding.conv
        (fun err => Data_encoding.Json.construct Error_monad.error_encoding err)
        (fun __json_value =>
          Data_encoding.Json.destruct Error_monad.error_encoding __json_value)
        None Data_encoding.__json_value) Error_monad.error_encoding).

Module successful_manager_operation_result.
  Module Reveal_result.
    Record record {consumed_gas : Set} := {
      consumed_gas : consumed_gas }.
    Arguments record : clear implicits.
  End Reveal_result.
  Definition Reveal_result_skeleton := Reveal_result.record.
  
  Module Transaction_result.
    Record record {storage big_map_diff balance_updates originated_contracts
      consumed_gas storage_size paid_storage_size_diff
      allocated_destination_contract : Set} := {
      storage : storage;
      big_map_diff : big_map_diff;
      balance_updates : balance_updates;
      originated_contracts : originated_contracts;
      consumed_gas : consumed_gas;
      storage_size : storage_size;
      paid_storage_size_diff : paid_storage_size_diff;
      allocated_destination_contract : allocated_destination_contract }.
    Arguments record : clear implicits.
  End Transaction_result.
  Definition Transaction_result_skeleton := Transaction_result.record.
  
  Module Origination_result.
    Record record {big_map_diff balance_updates originated_contracts
      consumed_gas storage_size paid_storage_size_diff : Set} := {
      big_map_diff : big_map_diff;
      balance_updates : balance_updates;
      originated_contracts : originated_contracts;
      consumed_gas : consumed_gas;
      storage_size : storage_size;
      paid_storage_size_diff : paid_storage_size_diff }.
    Arguments record : clear implicits.
  End Origination_result.
  Definition Origination_result_skeleton := Origination_result.record.
  
  Module Delegation_result.
    Record record {consumed_gas : Set} := {
      consumed_gas : consumed_gas }.
    Arguments record : clear implicits.
  End Delegation_result.
  Definition Delegation_result_skeleton := Delegation_result.record.
End successful_manager_operation_result.

Reserved Notation "'successful_manager_operation_result.Reveal_result".
Reserved Notation "'successful_manager_operation_result.Transaction_result".
Reserved Notation "'successful_manager_operation_result.Origination_result".
Reserved Notation "'successful_manager_operation_result.Delegation_result".
Reserved Notation "'successful_manager_operation_result".

Inductive successful_manager_operation_result_gadt : Set :=
| Reveal_result :
  'successful_manager_operation_result.Reveal_result ->
  successful_manager_operation_result_gadt
| Transaction_result :
  'successful_manager_operation_result.Transaction_result ->
  successful_manager_operation_result_gadt
| Origination_result :
  'successful_manager_operation_result.Origination_result ->
  successful_manager_operation_result_gadt
| Delegation_result :
  'successful_manager_operation_result.Delegation_result ->
  successful_manager_operation_result_gadt

where "'successful_manager_operation_result" := (fun (_ : Set) =>
  successful_manager_operation_result_gadt)
and "'successful_manager_operation_result.Reveal_result" :=
  (successful_manager_operation_result.Reveal_result_skeleton Z.t)
and "'successful_manager_operation_result.Transaction_result" :=
  (successful_manager_operation_result.Transaction_result_skeleton
    (option Alpha_context.Script.expr)
    (option Alpha_context.Contract.big_map_diff)
    Alpha_context.Delegate.balance_updates (list Alpha_context.Contract.t) Z.t
    Z.t Z.t bool)
and "'successful_manager_operation_result.Origination_result" :=
  (successful_manager_operation_result.Origination_result_skeleton
    (option Alpha_context.Contract.big_map_diff)
    Alpha_context.Delegate.balance_updates (list Alpha_context.Contract.t) Z.t
    Z.t Z.t)
and "'successful_manager_operation_result.Delegation_result" :=
  (successful_manager_operation_result.Delegation_result_skeleton Z.t).

Module ConstructorRecordNotations_successful_manager_operation_result_gadt.
  Module successful_manager_operation_result.
    Definition Reveal_result :=
      'successful_manager_operation_result.Reveal_result.
    Definition Transaction_result :=
      'successful_manager_operation_result.Transaction_result.
    Definition Origination_result :=
      'successful_manager_operation_result.Origination_result.
    Definition Delegation_result :=
      'successful_manager_operation_result.Delegation_result.
  End successful_manager_operation_result.
End ConstructorRecordNotations_successful_manager_operation_result_gadt.
Import ConstructorRecordNotations_successful_manager_operation_result_gadt.

Definition successful_manager_operation_result :=
  'successful_manager_operation_result.

Reserved Notation "'packed_successful_manager_operation_result".

Inductive packed_successful_manager_operation_result_gadt : Set :=
| Successful_manager_result : forall {kind : Set},
  successful_manager_operation_result kind ->
  packed_successful_manager_operation_result_gadt

where "'packed_successful_manager_operation_result" :=
  (packed_successful_manager_operation_result_gadt).

Definition packed_successful_manager_operation_result :=
  'packed_successful_manager_operation_result.

Reserved Notation "'manager_operation_result".

Inductive manager_operation_result_gadt : Set :=
| Applied : forall {kind : Set},
  successful_manager_operation_result kind -> manager_operation_result_gadt
| Backtracked : forall {kind : Set},
  successful_manager_operation_result kind ->
  option (list Error_monad.__error) -> manager_operation_result_gadt
| Failed : forall {kind : Set},
  Alpha_context.Kind.manager kind -> list Error_monad.__error ->
  manager_operation_result_gadt
| Skipped : forall {kind : Set},
  Alpha_context.Kind.manager kind -> manager_operation_result_gadt

where "'manager_operation_result" := (fun (_ : Set) =>
  manager_operation_result_gadt).

Definition manager_operation_result := 'manager_operation_result.

Reserved Notation "'packed_internal_operation_result".

Inductive packed_internal_operation_result_gadt : Set :=
| Internal_operation_result : forall {kind : Set},
  Alpha_context.internal_operation kind -> manager_operation_result kind ->
  packed_internal_operation_result_gadt

where "'packed_internal_operation_result" :=
  (packed_internal_operation_result_gadt).

Definition packed_internal_operation_result :=
  'packed_internal_operation_result.

Module Manager_result.
  Module case.
    Module MCase.
      Record record {op_case encoding kind iselect select proj inj t : Set} := {
        op_case : op_case;
        encoding : encoding;
        kind : kind;
        iselect : iselect;
        select : select;
        proj : proj;
        inj : inj;
        t : t }.
      Arguments record : clear implicits.
    End MCase.
    Definition MCase_skeleton := MCase.record.
  End case.
  
  Reserved Notation "'case.MCase".
  Reserved Notation "'case".
  
  Inductive case_gadt : Set :=
  | MCase : forall {a kind : Set}, 'case.MCase a kind -> case_gadt
  
  where "'case" := (fun (_ : Set) => case_gadt)
  and "'case.MCase" := (fun (t_a t_kind : Set) =>
    case.MCase_skeleton
      (Alpha_context.Operation.Encoding.Manager_operations.case t_kind)
      (Data_encoding.t t_a) (Alpha_context.Kind.manager t_kind)
      (packed_internal_operation_result ->
      option
        (Alpha_context.internal_operation t_kind *
          manager_operation_result t_kind))
      (packed_successful_manager_operation_result ->
      option (successful_manager_operation_result t_kind))
      (successful_manager_operation_result t_kind -> t_a)
      (t_a -> successful_manager_operation_result t_kind)
      (Data_encoding.t (manager_operation_result t_kind))).
  
  Module ConstructorRecordNotations_case_gadt.
    Module case.
      Definition MCase := 'case.MCase.
    End case.
  End ConstructorRecordNotations_case_gadt.
  Import ConstructorRecordNotations_case_gadt.
  
  Definition case := 'case.
  
  Definition make {A B : Set}
    (op_case : Alpha_context.Operation.Encoding.Manager_operations.case A)
    (encoding : Data_encoding.encoding B) (kind : Alpha_context.Kind.manager A)
    (iselect :
      packed_internal_operation_result ->
      option (Alpha_context.internal_operation A * manager_operation_result A))
    (select :
      packed_successful_manager_operation_result ->
      option (successful_manager_operation_result A))
    (proj : successful_manager_operation_result A -> B)
    (inj : B -> successful_manager_operation_result A) : case A :=
    let
      'Alpha_context.Operation.Encoding.Manager_operations.MCase {|
        Alpha_context.Operation.Encoding.Manager_operations.case.MCase.name := name
          |} := op_case in
    let __t_value :=
      Pervasives.op_atat
        (let arg :=
          Data_encoding.def
            (Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "operation.alpha.operation_result."
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format))
                "operation.alpha.operation_result.%s") name) in
        fun eta => arg None None eta)
        (Data_encoding.union
          (Some
            (* ❌ Variants not supported *)
            (* ❌ `Uint8 *)
            Data_encoding.Uint8)
          [
            Data_encoding.__case_value "Applied" None (Data_encoding.Tag 0)
              (Data_encoding.merge_objs
                (Data_encoding.obj1
                  (Data_encoding.req None None "status"
                    (Data_encoding.constant
                      "applied")))
                encoding)
              (fun o =>
                match o with
                | Skipped _ | Failed _ _ | Backtracked _ _ =>
                  None
                | Applied o =>
                  match
                    select
                      (Successful_manager_result
                        o) with
                  | None => None
                  | Some o => Some (tt, (proj o))
                  end
                end)
              (fun function_parameter =>
                let '(_, x) := function_parameter in
                Applied (inj x));
            Data_encoding.__case_value "Failed" None (Data_encoding.Tag 1)
              (Data_encoding.obj2
                (Data_encoding.req None None "status"
                  (Data_encoding.constant "failed"))
                (Data_encoding.req None None "errors"
                  (Data_encoding.__list_value None
                    error_encoding)))
              (fun function_parameter =>
                match function_parameter with
                | Failed _ errs => Some (tt, errs)
                | _ => None
                end)
              (fun function_parameter =>
                let '(_, errs) := function_parameter in
                Failed kind errs);
            Data_encoding.__case_value "Skipped" None (Data_encoding.Tag 2)
              (Data_encoding.obj1
                (Data_encoding.req None None "status"
                  (Data_encoding.constant "skipped")))
              (fun function_parameter =>
                match function_parameter with
                | Skipped _ => Some tt
                | _ => None
                end)
              (fun function_parameter =>
                let '_ := function_parameter in
                Skipped kind);
            Data_encoding.__case_value "Backtracked" None (Data_encoding.Tag 3)
              (Data_encoding.merge_objs
                (Data_encoding.obj2
                  (Data_encoding.req None None "status"
                    (Data_encoding.constant
                      "backtracked"))
                  (Data_encoding.opt None None "errors"
                    (Data_encoding.__list_value
                      None
                      error_encoding)))
                encoding)
              (fun o =>
                match o with
                | Skipped _ | Failed _ _ | Applied _ => None
                | Backtracked o errs =>
                  match
                    select
                      (Successful_manager_result
                        o) with
                  | None => None
                  | Some o =>
                    Some ((tt, errs), (proj o))
                  end
                end)
              (fun function_parameter =>
                let '((_, errs), x) := function_parameter in
                Backtracked (inj x) errs)
          ]) in
    MCase
      {| case.MCase.op_case := op_case; case.MCase.encoding := encoding;
        case.MCase.kind := kind; case.MCase.iselect := iselect;
        case.MCase.select := select; case.MCase.proj := proj;
        case.MCase.inj := inj; case.MCase.t := __t_value |}.
  
  Definition reveal_case : case Alpha_context.Kind.reveal :=
    make Alpha_context.Operation.Encoding.Manager_operations.reveal_case
      (Data_encoding.obj1
        (Data_encoding.dft None None "consumed_gas" Data_encoding.z Z.zero))
      Alpha_context.Kind.Reveal_manager_kind
      (fun function_parameter =>
        match function_parameter with
        |
          Internal_operation_result
            ({|
              Alpha_context.internal_operation.operation := Alpha_context.Reveal _
                |} as op) res => Some (op, res)
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        | Successful_manager_result ((Reveal_result _) as op) => Some op
        | _ => None
        end)
      (fun function_parameter =>
        let
          'Reveal_result {|
            successful_manager_operation_result.Reveal_result.consumed_gas := consumed_gas
              |} := function_parameter in
        consumed_gas)
      (fun consumed_gas =>
        Reveal_result
          {|
            successful_manager_operation_result.Reveal_result.consumed_gas :=
              consumed_gas |}).
  
  Definition transaction_case : case Alpha_context.Kind.transaction :=
    make Alpha_context.Operation.Encoding.Manager_operations.transaction_case
      (Data_encoding.obj8
        (Data_encoding.opt None None "storage"
          Alpha_context.Script.expr_encoding)
        (Data_encoding.opt None None "big_map_diff"
          Alpha_context.Contract.big_map_diff_encoding)
        (Data_encoding.dft None None "balance_updates"
          Alpha_context.Delegate.balance_updates_encoding [])
        (Data_encoding.dft None None "originated_contracts"
          (Data_encoding.__list_value None Alpha_context.Contract.encoding) [])
        (Data_encoding.dft None None "consumed_gas" Data_encoding.z Z.zero)
        (Data_encoding.dft None None "storage_size" Data_encoding.z Z.zero)
        (Data_encoding.dft None None "paid_storage_size_diff" Data_encoding.z
          Z.zero)
        (Data_encoding.dft None None "allocated_destination_contract"
          Data_encoding.__bool_value false))
      Alpha_context.Kind.Transaction_manager_kind
      (fun function_parameter =>
        match function_parameter with
        |
          Internal_operation_result
            ({|
              Alpha_context.internal_operation.operation := Alpha_context.Transaction _
                |} as op) res => Some (op, res)
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        | Successful_manager_result ((Transaction_result _) as op) => Some op
        | _ => None
        end)
      (fun function_parameter =>
        let
          'Transaction_result {|
            successful_manager_operation_result.Transaction_result.storage := storage;
              successful_manager_operation_result.Transaction_result.big_map_diff
                := big_map_diff;
              successful_manager_operation_result.Transaction_result.balance_updates
                := balance_updates;
              successful_manager_operation_result.Transaction_result.originated_contracts
                := originated_contracts;
              successful_manager_operation_result.Transaction_result.consumed_gas
                := consumed_gas;
              successful_manager_operation_result.Transaction_result.storage_size
                := storage_size;
              successful_manager_operation_result.Transaction_result.paid_storage_size_diff
                := paid_storage_size_diff;
              successful_manager_operation_result.Transaction_result.allocated_destination_contract
                := allocated_destination_contract
              |} := function_parameter in
        (storage, big_map_diff, balance_updates, originated_contracts,
          consumed_gas, storage_size, paid_storage_size_diff,
          allocated_destination_contract))
      (fun function_parameter =>
        let
          '(storage, big_map_diff, balance_updates, originated_contracts,
            consumed_gas, storage_size, paid_storage_size_diff,
            allocated_destination_contract) := function_parameter in
        Transaction_result
          {|
            successful_manager_operation_result.Transaction_result.storage :=
              storage;
            successful_manager_operation_result.Transaction_result.big_map_diff :=
              big_map_diff;
            successful_manager_operation_result.Transaction_result.balance_updates :=
              balance_updates;
            successful_manager_operation_result.Transaction_result.originated_contracts :=
              originated_contracts;
            successful_manager_operation_result.Transaction_result.consumed_gas :=
              consumed_gas;
            successful_manager_operation_result.Transaction_result.storage_size :=
              storage_size;
            successful_manager_operation_result.Transaction_result.paid_storage_size_diff :=
              paid_storage_size_diff;
            successful_manager_operation_result.Transaction_result.allocated_destination_contract :=
              allocated_destination_contract |}).
  
  Definition origination_case : case Alpha_context.Kind.origination :=
    make Alpha_context.Operation.Encoding.Manager_operations.origination_case
      (Data_encoding.obj6
        (Data_encoding.opt None None "big_map_diff"
          Alpha_context.Contract.big_map_diff_encoding)
        (Data_encoding.dft None None "balance_updates"
          Alpha_context.Delegate.balance_updates_encoding [])
        (Data_encoding.dft None None "originated_contracts"
          (Data_encoding.__list_value None Alpha_context.Contract.encoding) [])
        (Data_encoding.dft None None "consumed_gas" Data_encoding.z Z.zero)
        (Data_encoding.dft None None "storage_size" Data_encoding.z Z.zero)
        (Data_encoding.dft None None "paid_storage_size_diff" Data_encoding.z
          Z.zero)) Alpha_context.Kind.Origination_manager_kind
      (fun function_parameter =>
        match function_parameter with
        |
          Internal_operation_result
            ({|
              Alpha_context.internal_operation.operation := Alpha_context.Origination _
                |} as op) res => Some (op, res)
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        | Successful_manager_result ((Origination_result _) as op) => Some op
        | _ => None
        end)
      (fun function_parameter =>
        let
          'Origination_result {|
            successful_manager_operation_result.Origination_result.big_map_diff :=
              big_map_diff;
              successful_manager_operation_result.Origination_result.balance_updates
                := balance_updates;
              successful_manager_operation_result.Origination_result.originated_contracts
                := originated_contracts;
              successful_manager_operation_result.Origination_result.consumed_gas
                := consumed_gas;
              successful_manager_operation_result.Origination_result.storage_size
                := storage_size;
              successful_manager_operation_result.Origination_result.paid_storage_size_diff
                := paid_storage_size_diff
              |} := function_parameter in
        (big_map_diff, balance_updates, originated_contracts, consumed_gas,
          storage_size, paid_storage_size_diff))
      (fun function_parameter =>
        let
          '(big_map_diff, balance_updates, originated_contracts, consumed_gas,
            storage_size, paid_storage_size_diff) := function_parameter in
        Origination_result
          {|
            successful_manager_operation_result.Origination_result.big_map_diff :=
              big_map_diff;
            successful_manager_operation_result.Origination_result.balance_updates :=
              balance_updates;
            successful_manager_operation_result.Origination_result.originated_contracts :=
              originated_contracts;
            successful_manager_operation_result.Origination_result.consumed_gas :=
              consumed_gas;
            successful_manager_operation_result.Origination_result.storage_size :=
              storage_size;
            successful_manager_operation_result.Origination_result.paid_storage_size_diff :=
              paid_storage_size_diff |}).
  
  Definition delegation_case : case Alpha_context.Kind.delegation :=
    make Alpha_context.Operation.Encoding.Manager_operations.delegation_case
      (Data_encoding.obj1
        (Data_encoding.dft None None "consumed_gas" Data_encoding.z Z.zero))
      Alpha_context.Kind.Delegation_manager_kind
      (fun function_parameter =>
        match function_parameter with
        |
          Internal_operation_result
            ({|
              Alpha_context.internal_operation.operation := Alpha_context.Delegation _
                |} as op) res => Some (op, res)
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        | Successful_manager_result ((Delegation_result _) as op) => Some op
        | _ => None
        end)
      (fun function_parameter =>
        let
          'Delegation_result {|
            successful_manager_operation_result.Delegation_result.consumed_gas :=
              consumed_gas
              |} := function_parameter in
        consumed_gas)
      (fun consumed_gas =>
        Delegation_result
          {|
            successful_manager_operation_result.Delegation_result.consumed_gas :=
              consumed_gas |}).
End Manager_result.

Definition internal_operation_result_encoding
  : Data_encoding.t packed_internal_operation_result :=
  let make {A : Set} (function_parameter : Manager_result.case A)
    : Data_encoding.case packed_internal_operation_result :=
    let 'Manager_result.MCase res_case := function_parameter in
    let 'Alpha_context.Operation.Encoding.Manager_operations.MCase op_case :=
      Manager_result.case.MCase.op_case res_case in
    Data_encoding.__case_value
      (Alpha_context.Operation.Encoding.Manager_operations.case.MCase.name
        op_case) None
      (Data_encoding.Tag
        (Alpha_context.Operation.Encoding.Manager_operations.case.MCase.tag
          op_case))
      (Data_encoding.merge_objs
        (Data_encoding.obj3
          (Data_encoding.req None None "kind"
            (Data_encoding.constant
              (Alpha_context.Operation.Encoding.Manager_operations.case.MCase.name
                op_case)))
          (Data_encoding.req None None "source" Alpha_context.Contract.encoding)
          (Data_encoding.req None None "nonce" Data_encoding.uint16))
        (Data_encoding.merge_objs
          (Alpha_context.Operation.Encoding.Manager_operations.case.MCase.encoding
            op_case)
          (Data_encoding.obj1
            (Data_encoding.req None None "result"
              (Manager_result.case.MCase.t res_case)))))
      (fun op =>
        match (Manager_result.case.MCase.iselect res_case) op with
        | Some (op, res) =>
          Some
            ((tt, (Alpha_context.internal_operation.source op),
              (Alpha_context.internal_operation.nonce op)),
              (((Alpha_context.Operation.Encoding.Manager_operations.case.MCase.proj
                op_case) (Alpha_context.internal_operation.operation op)), res))
        | None => None
        end)
      (fun function_parameter =>
        let '((_, source, __nonce_value), (op, res)) := function_parameter in
        let op :=
          {| Alpha_context.internal_operation.source := source;
            Alpha_context.internal_operation.operation :=
              (Alpha_context.Operation.Encoding.Manager_operations.case.MCase.inj
                op_case) op;
            Alpha_context.internal_operation.nonce := __nonce_value |} in
        Internal_operation_result op res) in
  Pervasives.op_atat
    (let arg := Data_encoding.def "operation.alpha.internal_operation_result" in
    fun eta => arg None None eta)
    (Data_encoding.union None
      [
        make Manager_result.reveal_case;
        make Manager_result.transaction_case;
        make Manager_result.origination_case;
        make Manager_result.delegation_case
      ]).

Module contents_result.
  Module Endorsement_result.
    Record record {balance_updates delegate slots : Set} := {
      balance_updates : balance_updates;
      delegate : delegate;
      slots : slots }.
    Arguments record : clear implicits.
  End Endorsement_result.
  Definition Endorsement_result_skeleton := Endorsement_result.record.
  
  Module Manager_operation_result.
    Record record {balance_updates operation_result internal_operation_results :
      Set} := {
      balance_updates : balance_updates;
      operation_result : operation_result;
      internal_operation_results : internal_operation_results }.
    Arguments record : clear implicits.
  End Manager_operation_result.
  Definition Manager_operation_result_skeleton :=
    Manager_operation_result.record.
End contents_result.

Reserved Notation "'contents_result.Endorsement_result".
Reserved Notation "'contents_result.Manager_operation_result".
Reserved Notation "'contents_result".

Inductive contents_result_gadt : Set :=
| Endorsement_result :
  'contents_result.Endorsement_result -> contents_result_gadt
| Seed_nonce_revelation_result :
  Alpha_context.Delegate.balance_updates -> contents_result_gadt
| Double_endorsement_evidence_result :
  Alpha_context.Delegate.balance_updates -> contents_result_gadt
| Double_baking_evidence_result :
  Alpha_context.Delegate.balance_updates -> contents_result_gadt
| Activate_account_result :
  Alpha_context.Delegate.balance_updates -> contents_result_gadt
| Proposals_result : contents_result_gadt
| Ballot_result : contents_result_gadt
| Manager_operation_result : forall {kind : Set},
  'contents_result.Manager_operation_result kind -> contents_result_gadt

where "'contents_result" := (fun (_ : Set) => contents_result_gadt)
and "'contents_result.Endorsement_result" :=
  (contents_result.Endorsement_result_skeleton
    Alpha_context.Delegate.balance_updates
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) (list Z))
and "'contents_result.Manager_operation_result" := (fun (t_kind : Set) =>
  contents_result.Manager_operation_result_skeleton
    Alpha_context.Delegate.balance_updates (manager_operation_result t_kind)
    (list packed_internal_operation_result)).

Module ConstructorRecordNotations_contents_result_gadt.
  Module contents_result.
    Definition Endorsement_result := 'contents_result.Endorsement_result.
    Definition Manager_operation_result :=
      'contents_result.Manager_operation_result.
  End contents_result.
End ConstructorRecordNotations_contents_result_gadt.
Import ConstructorRecordNotations_contents_result_gadt.

Definition contents_result := 'contents_result.

Reserved Notation "'packed_contents_result".

Inductive packed_contents_result_gadt : Set :=
| Contents_result : forall {kind : Set},
  contents_result kind -> packed_contents_result_gadt

where "'packed_contents_result" := (packed_contents_result_gadt).

Definition packed_contents_result := 'packed_contents_result.

Reserved Notation "'packed_contents_and_result".

Inductive packed_contents_and_result_gadt : Set :=
| Contents_and_result : forall {kind : Set},
  Alpha_context.Operation.contents kind -> contents_result kind ->
  packed_contents_and_result_gadt

where "'packed_contents_and_result" := (packed_contents_and_result_gadt).

Definition packed_contents_and_result := 'packed_contents_and_result.

Reserved Notation "'eq".

Inductive eq_gadt : Set :=
| Eq : eq_gadt

where "'eq" := (fun (_ _ : Set) => eq_gadt).

Definition eq := 'eq.

Definition equal_manager_kind {a b : Set}
  (ka : Alpha_context.Kind.manager a) (kb : Alpha_context.Kind.manager b)
  : option (eq a b) :=
  match (ka, kb) with
  |
    (Alpha_context.Kind.Reveal_manager_kind,
      Alpha_context.Kind.Reveal_manager_kind) => Some Eq
  | (Alpha_context.Kind.Reveal_manager_kind, _) => None
  |
    (Alpha_context.Kind.Transaction_manager_kind,
      Alpha_context.Kind.Transaction_manager_kind) => Some Eq
  | (Alpha_context.Kind.Transaction_manager_kind, _) => None
  |
    (Alpha_context.Kind.Origination_manager_kind,
      Alpha_context.Kind.Origination_manager_kind) => Some Eq
  | (Alpha_context.Kind.Origination_manager_kind, _) => None
  |
    (Alpha_context.Kind.Delegation_manager_kind,
      Alpha_context.Kind.Delegation_manager_kind) => Some Eq
  | (Alpha_context.Kind.Delegation_manager_kind, _) => None
  end.

Module Encoding.
  Module case.
    Module Case.
      Record record {op_case encoding select mselect proj inj : Set} := {
        op_case : op_case;
        encoding : encoding;
        select : select;
        mselect : mselect;
        proj : proj;
        inj : inj }.
      Arguments record : clear implicits.
    End Case.
    Definition Case_skeleton := Case.record.
  End case.
  
  Reserved Notation "'case.Case".
  Reserved Notation "'case".
  
  Inductive case_gadt : Set :=
  | Case : forall {a kind : Set}, 'case.Case a kind -> case_gadt
  
  where "'case" := (fun (_ : Set) => case_gadt)
  and "'case.Case" := (fun (t_a t_kind : Set) =>
    case.Case_skeleton (Alpha_context.Operation.Encoding.case t_kind)
      (Data_encoding.t t_a)
      (packed_contents_result -> option (contents_result t_kind))
      (packed_contents_and_result ->
      option (Alpha_context.contents t_kind * contents_result t_kind))
      (contents_result t_kind -> t_a) (t_a -> contents_result t_kind)).
  
  Module ConstructorRecordNotations_case_gadt.
    Module case.
      Definition Case := 'case.Case.
    End case.
  End ConstructorRecordNotations_case_gadt.
  Import ConstructorRecordNotations_case_gadt.
  
  Definition case := 'case.
  
  Definition tagged_case {A B : Set}
    (tag : Data_encoding.case_tag) (name : string)
    (args : Data_encoding.encoding A) (proj : B -> option A) (inj : A -> B)
    : Data_encoding.case B :=
    Data_encoding.__case_value (String.capitalize_ascii name) None tag
      (Data_encoding.merge_objs
        (Data_encoding.obj1
          (Data_encoding.req None None "kind" (Data_encoding.constant name)))
        args)
      (fun x =>
        match proj x with
        | None => None
        | Some x => Some (tt, x)
        end)
      (fun function_parameter =>
        let '(_, x) := function_parameter in
        inj x).
  
  Definition endorsement_case : case Alpha_context.Kind.endorsement :=
    Case
      {| case.Case.op_case := Alpha_context.Operation.Encoding.endorsement_case;
        case.Case.encoding :=
          Data_encoding.obj3
            (Data_encoding.req None None "balance_updates"
              Alpha_context.Delegate.balance_updates_encoding)
            (Data_encoding.req None None "delegate"
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding))
            (Data_encoding.req None None "slots"
              (Data_encoding.__list_value None Data_encoding.uint8));
        case.Case.select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result ((Endorsement_result _) as op) => Some op
            | _ => None
            end;
        case.Case.mselect :=
          fun function_parameter =>
            match function_parameter with
            | Contents_and_result ((Alpha_context.Endorsement _) as op) res =>
              Some (op, res)
            | _ => None
            end;
        case.Case.proj :=
          fun function_parameter =>
            let
              'Endorsement_result {|
                contents_result.Endorsement_result.balance_updates := balance_updates;
                  contents_result.Endorsement_result.delegate := delegate;
                  contents_result.Endorsement_result.slots := slots
                  |} := function_parameter in
            (balance_updates, delegate, slots);
        case.Case.inj :=
          fun function_parameter =>
            let '(balance_updates, delegate, slots) := function_parameter in
            Endorsement_result
              {|
                contents_result.Endorsement_result.balance_updates :=
                  balance_updates;
                contents_result.Endorsement_result.delegate := delegate;
                contents_result.Endorsement_result.slots := slots |} |}.
  
  Definition seed_nonce_revelation_case
    : case Alpha_context.Kind.seed_nonce_revelation :=
    Case
      {|
        case.Case.op_case :=
          Alpha_context.Operation.Encoding.seed_nonce_revelation_case;
        case.Case.encoding :=
          Data_encoding.obj1
            (Data_encoding.req None None "balance_updates"
              Alpha_context.Delegate.balance_updates_encoding);
        case.Case.select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result ((Seed_nonce_revelation_result _) as op) =>
              Some op
            | _ => None
            end;
        case.Case.mselect :=
          fun function_parameter =>
            match function_parameter with
            |
              Contents_and_result
                ((Alpha_context.Seed_nonce_revelation _) as op) res =>
              Some (op, res)
            | _ => None
            end;
        case.Case.proj :=
          fun function_parameter =>
            let 'Seed_nonce_revelation_result bus := function_parameter in
            bus; case.Case.inj := fun bus => Seed_nonce_revelation_result bus |}.
  
  Definition double_endorsement_evidence_case
    : case Alpha_context.Kind.double_endorsement_evidence :=
    Case
      {|
        case.Case.op_case :=
          Alpha_context.Operation.Encoding.double_endorsement_evidence_case;
        case.Case.encoding :=
          Data_encoding.obj1
            (Data_encoding.req None None "balance_updates"
              Alpha_context.Delegate.balance_updates_encoding);
        case.Case.select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result ((Double_endorsement_evidence_result _) as op) =>
              Some op
            | _ => None
            end;
        case.Case.mselect :=
          fun function_parameter =>
            match function_parameter with
            |
              Contents_and_result
                ((Alpha_context.Double_endorsement_evidence _) as op) res =>
              Some (op, res)
            | _ => None
            end;
        case.Case.proj :=
          fun function_parameter =>
            let 'Double_endorsement_evidence_result bus := function_parameter in
            bus;
        case.Case.inj := fun bus => Double_endorsement_evidence_result bus |}.
  
  Definition double_baking_evidence_case
    : case Alpha_context.Kind.double_baking_evidence :=
    Case
      {|
        case.Case.op_case :=
          Alpha_context.Operation.Encoding.double_baking_evidence_case;
        case.Case.encoding :=
          Data_encoding.obj1
            (Data_encoding.req None None "balance_updates"
              Alpha_context.Delegate.balance_updates_encoding);
        case.Case.select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result ((Double_baking_evidence_result _) as op) =>
              Some op
            | _ => None
            end;
        case.Case.mselect :=
          fun function_parameter =>
            match function_parameter with
            |
              Contents_and_result
                ((Alpha_context.Double_baking_evidence _) as op) res =>
              Some (op, res)
            | _ => None
            end;
        case.Case.proj :=
          fun function_parameter =>
            let 'Double_baking_evidence_result bus := function_parameter in
            bus; case.Case.inj := fun bus => Double_baking_evidence_result bus
        |}.
  
  Definition activate_account_case : case Alpha_context.Kind.activate_account :=
    Case
      {|
        case.Case.op_case :=
          Alpha_context.Operation.Encoding.activate_account_case;
        case.Case.encoding :=
          Data_encoding.obj1
            (Data_encoding.req None None "balance_updates"
              Alpha_context.Delegate.balance_updates_encoding);
        case.Case.select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result ((Activate_account_result _) as op) => Some op
            | _ => None
            end;
        case.Case.mselect :=
          fun function_parameter =>
            match function_parameter with
            | Contents_and_result ((Alpha_context.Activate_account _) as op) res
              => Some (op, res)
            | _ => None
            end;
        case.Case.proj :=
          fun function_parameter =>
            let 'Activate_account_result bus := function_parameter in
            bus; case.Case.inj := fun bus => Activate_account_result bus |}.
  
  Definition proposals_case : case Alpha_context.Kind.proposals :=
    Case
      {| case.Case.op_case := Alpha_context.Operation.Encoding.proposals_case;
        case.Case.encoding := Data_encoding.empty;
        case.Case.select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result (Proposals_result as op) => Some op
            | _ => None
            end;
        case.Case.mselect :=
          fun function_parameter =>
            match function_parameter with
            | Contents_and_result ((Alpha_context.Proposals _) as op) res =>
              Some (op, res)
            | _ => None
            end;
        case.Case.proj :=
          fun function_parameter =>
            let 'Proposals_result := function_parameter in
            tt;
        case.Case.inj :=
          fun function_parameter =>
            let '_ := function_parameter in
            Proposals_result |}.
  
  Definition ballot_case : case Alpha_context.Kind.ballot :=
    Case
      {| case.Case.op_case := Alpha_context.Operation.Encoding.ballot_case;
        case.Case.encoding := Data_encoding.empty;
        case.Case.select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result (Ballot_result as op) => Some op
            | _ => None
            end;
        case.Case.mselect :=
          fun function_parameter =>
            match function_parameter with
            | Contents_and_result ((Alpha_context.Ballot _) as op) res =>
              Some (op, res)
            | _ => None
            end;
        case.Case.proj :=
          fun function_parameter =>
            let 'Ballot_result := function_parameter in
            tt;
        case.Case.inj :=
          fun function_parameter =>
            let '_ := function_parameter in
            Ballot_result |}.
  
  Definition make_manager_case {A : Set}
    (function_parameter :
      Alpha_context.Operation.Encoding.case (Alpha_context.Kind.manager A))
    : Manager_result.case A ->
    (packed_contents_and_result ->
    option
      (Alpha_context.contents (Alpha_context.Kind.manager A) *
        contents_result (Alpha_context.Kind.manager A))) ->
    case (Alpha_context.Kind.manager A) :=
    let 'Alpha_context.Operation.Encoding.Case op_case := function_parameter in
    fun function_parameter =>
      let 'Manager_result.MCase res_case := function_parameter in
      fun mselect =>
        Case
          {| case.Case.op_case := Alpha_context.Operation.Encoding.Case op_case;
            case.Case.encoding :=
              Data_encoding.obj3
                (Data_encoding.req None None "balance_updates"
                  Alpha_context.Delegate.balance_updates_encoding)
                (Data_encoding.req None None "operation_result"
                  (Manager_result.case.MCase.t res_case))
                (Data_encoding.dft None None "internal_operation_results"
                  (Data_encoding.__list_value None
                    internal_operation_result_encoding) []);
            case.Case.select :=
              fun function_parameter =>
                match function_parameter with
                |
                  Contents_result
                    (Manager_operation_result
                      ({|
                        contents_result.Manager_operation_result.operation_result := Applied res
                          |} as op)) =>
                  match
                    (Manager_result.case.MCase.select res_case)
                      (Successful_manager_result res) with
                  | Some res =>
                    Some
                      (Manager_operation_result
                        (contents_result.Manager_operation_result.with_operation_result
                          (Applied res) op))
                  | None => None
                  end
                |
                  Contents_result
                    (Manager_operation_result
                      ({|
                        contents_result.Manager_operation_result.operation_result :=
                          Backtracked res errs
                          |} as op)) =>
                  match
                    (Manager_result.case.MCase.select res_case)
                      (Successful_manager_result res) with
                  | Some res =>
                    Some
                      (Manager_operation_result
                        (contents_result.Manager_operation_result.with_operation_result
                          (Backtracked res errs) op))
                  | None => None
                  end
                |
                  Contents_result
                    (Manager_operation_result
                      ({|
                        contents_result.Manager_operation_result.operation_result := Skipped kind
                          |} as op)) =>
                  match
                    equal_manager_kind kind
                      (Manager_result.case.MCase.kind res_case) with
                  | None => None
                  | Some Eq =>
                    Some
                      (Manager_operation_result
                        (contents_result.Manager_operation_result.with_operation_result
                          (Skipped kind) op))
                  end
                |
                  Contents_result
                    (Manager_operation_result
                      ({|
                        contents_result.Manager_operation_result.operation_result := Failed kind errs
                          |} as op)) =>
                  match
                    equal_manager_kind kind
                      (Manager_result.case.MCase.kind res_case) with
                  | None => None
                  | Some Eq =>
                    Some
                      (Manager_operation_result
                        (contents_result.Manager_operation_result.with_operation_result
                          (Failed kind errs) op))
                  end
                | Contents_result Ballot_result => None
                | Contents_result (Endorsement_result _) => None
                | Contents_result (Seed_nonce_revelation_result _) => None
                | Contents_result (Double_endorsement_evidence_result _) => None
                | Contents_result (Double_baking_evidence_result _) => None
                | Contents_result (Activate_account_result _) => None
                | Contents_result Proposals_result => None
                end; case.Case.mselect := mselect;
            case.Case.proj :=
              fun function_parameter =>
                let
                  'Manager_operation_result {|
                    contents_result.Manager_operation_result.balance_updates := bus;
                      contents_result.Manager_operation_result.operation_result
                        := r;
                      contents_result.Manager_operation_result.internal_operation_results
                        := rs
                      |} := function_parameter in
                (bus, r, rs);
            case.Case.inj :=
              fun function_parameter =>
                let '(bus, r, rs) := function_parameter in
                Manager_operation_result
                  {|
                    contents_result.Manager_operation_result.balance_updates :=
                      bus;
                    contents_result.Manager_operation_result.operation_result :=
                      r;
                    contents_result.Manager_operation_result.internal_operation_results :=
                      rs |} |}.
  
  Definition reveal_case
    : case (Alpha_context.Kind.manager Alpha_context.Kind.reveal) :=
    make_manager_case Alpha_context.Operation.Encoding.reveal_case
      Manager_result.reveal_case
      (fun function_parameter =>
        match function_parameter with
        |
          Contents_and_result
            ((Alpha_context.Manager_operation {|
              Alpha_context.contents.Manager_operation.operation := Alpha_context.Reveal _
                |}) as op) res => Some (op, res)
        | _ => None
        end).
  
  Definition transaction_case
    : case (Alpha_context.Kind.manager Alpha_context.Kind.transaction) :=
    make_manager_case Alpha_context.Operation.Encoding.transaction_case
      Manager_result.transaction_case
      (fun function_parameter =>
        match function_parameter with
        |
          Contents_and_result
            ((Alpha_context.Manager_operation {|
              Alpha_context.contents.Manager_operation.operation :=
                Alpha_context.Transaction _
                |}) as op) res => Some (op, res)
        | _ => None
        end).
  
  Definition origination_case
    : case (Alpha_context.Kind.manager Alpha_context.Kind.origination) :=
    make_manager_case Alpha_context.Operation.Encoding.origination_case
      Manager_result.origination_case
      (fun function_parameter =>
        match function_parameter with
        |
          Contents_and_result
            ((Alpha_context.Manager_operation {|
              Alpha_context.contents.Manager_operation.operation :=
                Alpha_context.Origination _
                |}) as op) res => Some (op, res)
        | _ => None
        end).
  
  Definition delegation_case
    : case (Alpha_context.Kind.manager Alpha_context.Kind.delegation) :=
    make_manager_case Alpha_context.Operation.Encoding.delegation_case
      Manager_result.delegation_case
      (fun function_parameter =>
        match function_parameter with
        |
          Contents_and_result
            ((Alpha_context.Manager_operation {|
              Alpha_context.contents.Manager_operation.operation :=
                Alpha_context.Delegation _
                |}) as op) res => Some (op, res)
        | _ => None
        end).
End Encoding.

Definition contents_result_encoding
  : Data_encoding.encoding packed_contents_result :=
  let make {A : Set} (function_parameter : Encoding.case A)
    : Data_encoding.case packed_contents_result :=
    let
      'Encoding.Case {|
        Encoding.case.Case.op_case :=
          Alpha_context.Operation.Encoding.Case {|
            Alpha_context.Operation.Encoding.case.Case.tag := tag;
              Alpha_context.Operation.Encoding.case.Case.name :=
                name
              |};
          Encoding.case.Case.encoding := encoding;
          Encoding.case.Case.select := select;
          Encoding.case.Case.mselect := _;
          Encoding.case.Case.proj := proj;
          Encoding.case.Case.inj := inj
          |} := function_parameter in
    let proj (x : packed_contents_result) : option __Case_'a :=
      match select x with
      | None => None
      | Some x => Some (proj x)
      end in
    let inj (x : __Case_'a) : packed_contents_result :=
      Contents_result (inj x) in
    tagged_case (Data_encoding.Tag tag) name encoding proj inj in
  Pervasives.op_atat
    (let arg := Data_encoding.def "operation.alpha.contents_result" in
    fun eta => arg None None eta)
    (Data_encoding.union None
      [
        make endorsement_case;
        make seed_nonce_revelation_case;
        make double_endorsement_evidence_case;
        make double_baking_evidence_case;
        make activate_account_case;
        make proposals_case;
        make ballot_case;
        make reveal_case;
        make transaction_case;
        make origination_case;
        make delegation_case
      ]).

Definition contents_and_result_encoding
  : Data_encoding.encoding packed_contents_and_result :=
  let make {A : Set} (function_parameter : Encoding.case A)
    : Data_encoding.case packed_contents_and_result :=
    let
      'Encoding.Case {|
        Encoding.case.Case.op_case :=
          Alpha_context.Operation.Encoding.Case {|
            Alpha_context.Operation.Encoding.case.Case.tag := tag;
              Alpha_context.Operation.Encoding.case.Case.name :=
                name;
              Alpha_context.Operation.Encoding.case.Case.encoding :=
                encoding;
              Alpha_context.Operation.Encoding.case.Case.proj :=
                proj;
              Alpha_context.Operation.Encoding.case.Case.inj := inj
              |};
          Encoding.case.Case.encoding := meta_encoding;
          Encoding.case.Case.mselect := mselect;
          Encoding.case.Case.proj := meta_proj;
          Encoding.case.Case.inj := meta_inj
          |} := function_parameter in
    let proj (c : packed_contents_and_result)
      : option (__Case_'a1 * __Case_'a) :=
      match mselect c with
      | Some (op, res) => Some ((proj op), (meta_proj res))
      | _ => None
      end in
    let inj (function_parameter : __Case_'a1 * __Case_'a)
      : packed_contents_and_result :=
      let '(op, res) := function_parameter in
      Contents_and_result (inj op) (meta_inj res) in
    let encoding :=
      Data_encoding.merge_objs encoding
        (Data_encoding.obj1
          (Data_encoding.req None None "metadata" meta_encoding)) in
    tagged_case (Data_encoding.Tag tag) name encoding proj inj in
  Pervasives.op_atat
    (let arg :=
      Data_encoding.def "operation.alpha.operation_contents_and_result" in
    fun eta => arg None None eta)
    (Data_encoding.union None
      [
        make endorsement_case;
        make seed_nonce_revelation_case;
        make double_endorsement_evidence_case;
        make double_baking_evidence_case;
        make activate_account_case;
        make proposals_case;
        make ballot_case;
        make reveal_case;
        make transaction_case;
        make origination_case;
        make delegation_case
      ]).

Reserved Notation "'contents_result_list".

Inductive contents_result_list_gadt : Set :=
| Single_result : forall {kind : Set},
  contents_result kind -> contents_result_list_gadt
| Cons_result : forall {kind : Set},
  contents_result (Alpha_context.Kind.manager kind) ->
  contents_result_list_gadt -> contents_result_list_gadt

where "'contents_result_list" := (fun (_ : Set) => contents_result_list_gadt).

Definition contents_result_list := 'contents_result_list.

Reserved Notation "'packed_contents_result_list".

Inductive packed_contents_result_list_gadt : Set :=
| Contents_result_list : forall {kind : Set},
  contents_result_list kind -> packed_contents_result_list_gadt

where "'packed_contents_result_list" := (packed_contents_result_list_gadt).

Definition packed_contents_result_list := 'packed_contents_result_list.

Definition contents_result_list_encoding
  : Data_encoding.encoding packed_contents_result_list :=
  let fix to_list (function_parameter : packed_contents_result_list)
    {struct function_parameter} : list packed_contents_result :=
    match function_parameter with
    | Contents_result_list (Single_result o) => [ Contents_result o ]
    | Contents_result_list (Cons_result o os) =>
      cons (Contents_result o) (to_list (Contents_result_list os))
    end in
  let fix of_list (function_parameter : list packed_contents_result)
    {struct function_parameter} : packed_contents_result_list :=
    match function_parameter with
    | [] => Pervasives.failwith "cannot decode empty operation result"
    | cons (Contents_result o) [] => Contents_result_list (Single_result o)
    | cons (Contents_result o) os =>
      let 'Contents_result_list os := of_list os in
      match (o, os) with
      | (Manager_operation_result _, Single_result (Manager_operation_result _))
        => Contents_result_list (Cons_result o os)
      | (Manager_operation_result _, Cons_result _ _) =>
        Contents_result_list (Cons_result o os)
      | _ => Pervasives.failwith "cannot decode ill-formed operation result"
      end
    end in
  Pervasives.op_atat
    (let arg := Data_encoding.def "operation.alpha.contents_list_result" in
    fun eta => arg None None eta)
    (Data_encoding.conv to_list of_list None
      (Data_encoding.__list_value None contents_result_encoding)).

Reserved Notation "'contents_and_result_list".

Inductive contents_and_result_list_gadt : Set :=
| Single_and_result : forall {kind : Set},
  Alpha_context.contents kind -> contents_result kind ->
  contents_and_result_list_gadt
| Cons_and_result : forall {kind : Set},
  Alpha_context.contents (Alpha_context.Kind.manager kind) ->
  contents_result (Alpha_context.Kind.manager kind) ->
  contents_and_result_list_gadt -> contents_and_result_list_gadt

where "'contents_and_result_list" := (fun (_ : Set) =>
  contents_and_result_list_gadt).

Definition contents_and_result_list := 'contents_and_result_list.

Reserved Notation "'packed_contents_and_result_list".

Inductive packed_contents_and_result_list_gadt : Set :=
| Contents_and_result_list : forall {kind : Set},
  contents_and_result_list kind -> packed_contents_and_result_list_gadt

where "'packed_contents_and_result_list" :=
  (packed_contents_and_result_list_gadt).

Definition packed_contents_and_result_list := 'packed_contents_and_result_list.

Definition contents_and_result_list_encoding
  : Data_encoding.encoding packed_contents_and_result_list :=
  let fix to_list (function_parameter : packed_contents_and_result_list)
    {struct function_parameter} : list packed_contents_and_result :=
    match function_parameter with
    | Contents_and_result_list (Single_and_result op res) =>
      [ Contents_and_result op res ]
    | Contents_and_result_list (Cons_and_result op res rest) =>
      cons (Contents_and_result op res)
        (to_list (Contents_and_result_list rest))
    end in
  let fix of_list (function_parameter : list packed_contents_and_result)
    {struct function_parameter} : packed_contents_and_result_list :=
    match function_parameter with
    | [] => Pervasives.failwith "cannot decode empty combined operation result"
    | cons (Contents_and_result op res) [] =>
      Contents_and_result_list (Single_and_result op res)
    | cons (Contents_and_result op res) rest =>
      let 'Contents_and_result_list rest := of_list rest in
      match (op, rest) with
      |
        (Alpha_context.Manager_operation _,
          Single_and_result (Alpha_context.Manager_operation _) _) =>
        Contents_and_result_list (Cons_and_result op res rest)
      | (Alpha_context.Manager_operation _, Cons_and_result _ _ _) =>
        Contents_and_result_list (Cons_and_result op res rest)
      | _ =>
        Pervasives.failwith "cannot decode ill-formed combined operation result"
      end
    end in
  Data_encoding.conv to_list of_list None
    (Data_encoding.__Variable.__list_value None contents_and_result_encoding).

Module operation_metadata.
  Record record {kind : Set} := Build {
    contents : contents_result_list kind }.
  Arguments record : clear implicits.
  Definition with_contents {t_kind} contents (r : record t_kind) :=
    Build t_kind contents.
End operation_metadata.
Definition operation_metadata := operation_metadata.record.

Reserved Notation "'packed_operation_metadata".

Inductive packed_operation_metadata_gadt : Set :=
| Operation_metadata : forall {kind : Set},
  operation_metadata kind -> packed_operation_metadata_gadt
| No_operation_metadata : packed_operation_metadata_gadt

where "'packed_operation_metadata" := (packed_operation_metadata_gadt).

Definition packed_operation_metadata := 'packed_operation_metadata.

Definition operation_metadata_encoding
  : Data_encoding.encoding packed_operation_metadata :=
  Pervasives.op_atat
    (let arg := Data_encoding.def "operation.alpha.result" in
    fun eta => arg None None eta)
    (Data_encoding.union None
      [
        Data_encoding.__case_value "Operation_metadata" None
          (Data_encoding.Tag 0) contents_result_list_encoding
          (fun function_parameter =>
            match function_parameter with
            |
              Operation_metadata {|
                operation_metadata.contents := contents
                  |} => Some (Contents_result_list contents)
            | _ => None
            end)
          (fun function_parameter =>
            let 'Contents_result_list contents := function_parameter in
            Operation_metadata
              {| operation_metadata.contents := contents |});
        Data_encoding.__case_value "No_operation_metadata" None
          (Data_encoding.Tag 1) Data_encoding.empty
          (fun function_parameter =>
            match function_parameter with
            | No_operation_metadata => Some tt
            | _ => None
            end)
          (fun function_parameter =>
            let '_ := function_parameter in
            No_operation_metadata)
      ]).

Definition kind_equal {kind kind2 : Set}
  (op : Alpha_context.contents kind) (res : contents_result kind2)
  : option (eq kind kind2) :=
  match (op, res) with
  | (Alpha_context.Endorsement _, Endorsement_result _) => Some Eq
  | (Alpha_context.Endorsement _, _) => None
  | (Alpha_context.Seed_nonce_revelation _, Seed_nonce_revelation_result _) =>
    Some Eq
  | (Alpha_context.Seed_nonce_revelation _, _) => None
  |
    (Alpha_context.Double_endorsement_evidence _,
      Double_endorsement_evidence_result _) => Some Eq
  | (Alpha_context.Double_endorsement_evidence _, _) => None
  | (Alpha_context.Double_baking_evidence _, Double_baking_evidence_result _) =>
    Some Eq
  | (Alpha_context.Double_baking_evidence _, _) => None
  | (Alpha_context.Activate_account _, Activate_account_result _) => Some Eq
  | (Alpha_context.Activate_account _, _) => None
  | (Alpha_context.Proposals _, Proposals_result) => Some Eq
  | (Alpha_context.Proposals _, _) => None
  | (Alpha_context.Ballot _, Ballot_result) => Some Eq
  | (Alpha_context.Ballot _, _) => None
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation := Alpha_context.Reveal _
        |},
      Manager_operation_result {|
        contents_result.Manager_operation_result.operation_result :=
          Applied (Reveal_result _)
          |}) => Some Eq
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation := Alpha_context.Reveal _
        |},
      Manager_operation_result {|
        contents_result.Manager_operation_result.operation_result :=
          Backtracked (Reveal_result _) _
          |}) => Some Eq
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation := Alpha_context.Reveal _
        |},
      Manager_operation_result {|
        contents_result.Manager_operation_result.operation_result :=
          Failed Alpha_context.Kind.Reveal_manager_kind _
          |}) => Some Eq
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation := Alpha_context.Reveal _
        |},
      Manager_operation_result {|
        contents_result.Manager_operation_result.operation_result :=
          Skipped Alpha_context.Kind.Reveal_manager_kind
          |}) => Some Eq
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation := Alpha_context.Reveal _
        |}, _) => None
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation :=
        Alpha_context.Transaction _
        |},
      Manager_operation_result {|
        contents_result.Manager_operation_result.operation_result :=
          Applied (Transaction_result _)
          |}) => Some Eq
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation :=
        Alpha_context.Transaction _
        |},
      Manager_operation_result {|
        contents_result.Manager_operation_result.operation_result :=
          Backtracked (Transaction_result _) _
          |}) => Some Eq
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation :=
        Alpha_context.Transaction _
        |},
      Manager_operation_result {|
        contents_result.Manager_operation_result.operation_result :=
          Failed Alpha_context.Kind.Transaction_manager_kind _
          |}) => Some Eq
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation :=
        Alpha_context.Transaction _
        |},
      Manager_operation_result {|
        contents_result.Manager_operation_result.operation_result :=
          Skipped Alpha_context.Kind.Transaction_manager_kind
          |}) => Some Eq
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation :=
        Alpha_context.Transaction _
        |}, _) => None
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation :=
        Alpha_context.Origination _
        |},
      Manager_operation_result {|
        contents_result.Manager_operation_result.operation_result :=
          Applied (Origination_result _)
          |}) => Some Eq
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation :=
        Alpha_context.Origination _
        |},
      Manager_operation_result {|
        contents_result.Manager_operation_result.operation_result :=
          Backtracked (Origination_result _) _
          |}) => Some Eq
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation :=
        Alpha_context.Origination _
        |},
      Manager_operation_result {|
        contents_result.Manager_operation_result.operation_result :=
          Failed Alpha_context.Kind.Origination_manager_kind _
          |}) => Some Eq
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation :=
        Alpha_context.Origination _
        |},
      Manager_operation_result {|
        contents_result.Manager_operation_result.operation_result :=
          Skipped Alpha_context.Kind.Origination_manager_kind
          |}) => Some Eq
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation :=
        Alpha_context.Origination _
        |}, _) => None
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation :=
        Alpha_context.Delegation _
        |},
      Manager_operation_result {|
        contents_result.Manager_operation_result.operation_result :=
          Applied (Delegation_result _)
          |}) => Some Eq
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation :=
        Alpha_context.Delegation _
        |},
      Manager_operation_result {|
        contents_result.Manager_operation_result.operation_result :=
          Backtracked (Delegation_result _) _
          |}) => Some Eq
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation :=
        Alpha_context.Delegation _
        |},
      Manager_operation_result {|
        contents_result.Manager_operation_result.operation_result :=
          Failed Alpha_context.Kind.Delegation_manager_kind _
          |}) => Some Eq
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation :=
        Alpha_context.Delegation _
        |},
      Manager_operation_result {|
        contents_result.Manager_operation_result.operation_result :=
          Skipped Alpha_context.Kind.Delegation_manager_kind
          |}) => Some Eq
  |
    (Alpha_context.Manager_operation {|
      Alpha_context.contents.Manager_operation.operation :=
        Alpha_context.Delegation _
        |}, _) => None
  end.

Fixpoint kind_equal_list {kind kind2 : Set}
  (contents : Alpha_context.contents_list kind)
  (res : contents_result_list kind2) {struct contents}
  : option (eq kind kind2) :=
  match (contents, res) with
  | (Alpha_context.Single op, Single_result res) =>
    match kind_equal op res with
    | None => None
    | Some Eq => Some Eq
    end
  | (Alpha_context.Cons op ops, Cons_result res ress) =>
    match kind_equal op res with
    | None => None
    | Some Eq =>
      match kind_equal_list ops ress with
      | None => None
      | Some Eq => Some Eq
      end
    end
  | _ => None
  end.

Fixpoint pack_contents_list {kind : Set}
  (contents : Alpha_context.contents_list kind)
  (res : contents_result_list kind) {struct contents}
  : contents_and_result_list kind :=
  match (contents, res) with
  | (Alpha_context.Single op, Single_result res) => Single_and_result op res
  | (Alpha_context.Cons op ops, Cons_result res ress) =>
    Cons_and_result op res (pack_contents_list ops ress)
  |
    (Alpha_context.Single (Alpha_context.Manager_operation _),
      Cons_result (Manager_operation_result _) (Single_result _)) =>
    (* ❌ Unreachable expressions are not supported *)
    unreachable
  |
    (Alpha_context.Cons _ _,
      Single_result
        (Manager_operation_result {|
          contents_result.Manager_operation_result.operation_result := Failed _ _
            |})) =>
    (* ❌ Unreachable expressions are not supported *)
    unreachable
  |
    (Alpha_context.Cons _ _,
      Single_result
        (Manager_operation_result {|
          contents_result.Manager_operation_result.operation_result := Skipped _
            |})) =>
    (* ❌ Unreachable expressions are not supported *)
    unreachable
  |
    (Alpha_context.Cons _ _,
      Single_result
        (Manager_operation_result {|
          contents_result.Manager_operation_result.operation_result := Applied _
            |})) =>
    (* ❌ Unreachable expressions are not supported *)
    unreachable
  |
    (Alpha_context.Cons _ _,
      Single_result
        (Manager_operation_result {|
          contents_result.Manager_operation_result.operation_result := Backtracked _ _
            |})) =>
    (* ❌ Unreachable expressions are not supported *)
    unreachable
  | (Alpha_context.Single _, Cons_result _ _) =>
    (* ❌ Unreachable expressions are not supported *)
    unreachable
  end.

Fixpoint unpack_contents_list {kind : Set}
  (function_parameter : contents_and_result_list kind)
  {struct function_parameter}
  : Alpha_context.contents_list kind * contents_result_list kind :=
  match function_parameter with
  | Single_and_result op res => ((Alpha_context.Single op), (Single_result res))
  | Cons_and_result op res rest =>
    let '(ops, ress) := unpack_contents_list rest in
    ((Alpha_context.Cons op ops), (Cons_result res ress))
  end.

Fixpoint to_list (function_parameter : packed_contents_result_list)
  {struct function_parameter} : list packed_contents_result :=
  match function_parameter with
  | Contents_result_list (Single_result o) => [ Contents_result o ]
  | Contents_result_list (Cons_result o os) =>
    cons (Contents_result o) (to_list (Contents_result_list os))
  end.

Fixpoint of_list (function_parameter : list packed_contents_result)
  {struct function_parameter} : packed_contents_result_list :=
  match function_parameter with
  | [] =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | cons (Contents_result o) [] => Contents_result_list (Single_result o)
  | cons (Contents_result o) os =>
    let 'Contents_result_list os := of_list os in
    match (o, os) with
    | (Manager_operation_result _, Single_result (Manager_operation_result _))
      => Contents_result_list (Cons_result o os)
    | (Manager_operation_result _, Cons_result _ _) =>
      Contents_result_list (Cons_result o os)
    | _ =>
      Pervasives.failwith
        "Operation result list of length > 1 should only contains manager operations result."
    end
  end.

Definition operation_data_and_metadata_encoding
  : Data_encoding.encoding
    (Alpha_context.packed_protocol_data * packed_operation_metadata) :=
  Pervasives.op_atat
    (let arg := Data_encoding.def "operation.alpha.operation_with_metadata" in
    fun eta => arg None None eta)
    (Data_encoding.union None
      [
        Data_encoding.__case_value "Operation_with_metadata" None
          (Data_encoding.Tag 0)
          (Data_encoding.obj2
            (Data_encoding.req None None "contents"
              (Data_encoding.dynamic_size None
                contents_and_result_list_encoding))
            (Data_encoding.opt None None "signature" Signature.encoding))
          (fun function_parameter =>
            match function_parameter with
            | (Alpha_context.Operation_data _, No_operation_metadata) =>
              None
            | (Alpha_context.Operation_data op, Operation_metadata res)
              =>
              match
                kind_equal_list
                  (Alpha_context.protocol_data.contents op)
                  (operation_metadata.contents res) with
              | None =>
                Pervasives.failwith
                  "cannot decode inconsistent combined operation result"
              | Some Eq =>
                Some
                  ((Contents_and_result_list
                    (pack_contents_list
                      (Alpha_context.protocol_data.contents
                        op)
                      (operation_metadata.contents
                        res))),
                    (Alpha_context.protocol_data.signature
                      op))
              end
            end)
          (fun function_parameter =>
            let '(Contents_and_result_list contents, signature) :=
              function_parameter in
            let '(op_contents, res_contents) :=
              unpack_contents_list contents in
            ((Alpha_context.Operation_data
              {|
                Alpha_context.protocol_data.contents :=
                  op_contents;
                Alpha_context.protocol_data.signature :=
                  signature |}),
              (Operation_metadata
                {| operation_metadata.contents := res_contents
                  |})));
        Data_encoding.__case_value "Operation_without_metadata" None
          (Data_encoding.Tag 1)
          (Data_encoding.obj2
            (Data_encoding.req None None "contents"
              (Data_encoding.dynamic_size None
                Alpha_context.Operation.contents_list_encoding))
            (Data_encoding.opt None None "signature" Signature.encoding))
          (fun function_parameter =>
            match function_parameter with
            | (Alpha_context.Operation_data op, No_operation_metadata)
              =>
              Some
                ((Alpha_context.Contents_list
                  (Alpha_context.protocol_data.contents op)),
                  (Alpha_context.protocol_data.signature op))
            | (Alpha_context.Operation_data _, Operation_metadata _) =>
              None
            end)
          (fun function_parameter =>
            let '(Alpha_context.Contents_list contents, signature) :=
              function_parameter in
            ((Alpha_context.Operation_data
              {| Alpha_context.protocol_data.contents := contents;
                Alpha_context.protocol_data.signature :=
                  signature |}), No_operation_metadata))
      ]).

Module block_metadata.
  Record record := Build {
    baker : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
    level : Alpha_context.Level.t;
    voting_period_kind : Alpha_context.Voting_period.kind;
    nonce_hash : option Nonce_hash.t;
    consumed_gas : Z.t;
    deactivated : list (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
    balance_updates : Alpha_context.Delegate.balance_updates }.
  Definition with_baker baker (r : record) :=
    Build baker r.(level) r.(voting_period_kind) r.(nonce_hash) r.(consumed_gas)
      r.(deactivated) r.(balance_updates).
  Definition with_level level (r : record) :=
    Build r.(baker) level r.(voting_period_kind) r.(nonce_hash) r.(consumed_gas)
      r.(deactivated) r.(balance_updates).
  Definition with_voting_period_kind voting_period_kind (r : record) :=
    Build r.(baker) r.(level) voting_period_kind r.(nonce_hash) r.(consumed_gas)
      r.(deactivated) r.(balance_updates).
  Definition with_nonce_hash nonce_hash (r : record) :=
    Build r.(baker) r.(level) r.(voting_period_kind) nonce_hash r.(consumed_gas)
      r.(deactivated) r.(balance_updates).
  Definition with_consumed_gas consumed_gas (r : record) :=
    Build r.(baker) r.(level) r.(voting_period_kind) r.(nonce_hash) consumed_gas
      r.(deactivated) r.(balance_updates).
  Definition with_deactivated deactivated (r : record) :=
    Build r.(baker) r.(level) r.(voting_period_kind) r.(nonce_hash)
      r.(consumed_gas) deactivated r.(balance_updates).
  Definition with_balance_updates balance_updates (r : record) :=
    Build r.(baker) r.(level) r.(voting_period_kind) r.(nonce_hash)
      r.(consumed_gas) r.(deactivated) balance_updates.
End block_metadata.
Definition block_metadata := block_metadata.record.

Definition block_metadata_encoding : Data_encoding.encoding block_metadata :=
  Pervasives.op_atat
    (let arg := Data_encoding.def "block_header.alpha.metadata" in
    fun eta => arg None None eta)
    (Data_encoding.conv
      (fun function_parameter =>
        let '{|
          block_metadata.baker := baker;
            block_metadata.level := level;
            block_metadata.voting_period_kind := voting_period_kind;
            block_metadata.nonce_hash := nonce_hash;
            block_metadata.consumed_gas := consumed_gas;
            block_metadata.deactivated := deactivated;
            block_metadata.balance_updates := balance_updates
            |} := function_parameter in
        (baker, level, voting_period_kind, nonce_hash, consumed_gas,
          deactivated, balance_updates))
      (fun function_parameter =>
        let
          '(baker, level, voting_period_kind, nonce_hash, consumed_gas,
            deactivated, balance_updates) := function_parameter in
        {| block_metadata.baker := baker; block_metadata.level := level;
          block_metadata.voting_period_kind := voting_period_kind;
          block_metadata.nonce_hash := nonce_hash;
          block_metadata.consumed_gas := consumed_gas;
          block_metadata.deactivated := deactivated;
          block_metadata.balance_updates := balance_updates |}) None
      (Data_encoding.obj7
        (Data_encoding.req None None "baker"
          (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding))
        (Data_encoding.req None None "level" Alpha_context.Level.encoding)
        (Data_encoding.req None None "voting_period_kind"
          Alpha_context.Voting_period.kind_encoding)
        (Data_encoding.req None None "nonce_hash"
          (Data_encoding.__option_value Nonce_hash.encoding))
        (Data_encoding.req None None "consumed_gas"
          (Data_encoding.check_size 10 Data_encoding.n))
        (Data_encoding.req None None "deactivated"
          (Data_encoding.__list_value None
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding)))
        (Data_encoding.req None None "balance_updates"
          Alpha_context.Delegate.balance_updates_encoding))).

Apply_results_mli

  • OCaml size: 190 lines
  • Coq size: 351 lines (+84% compared to OCaml)
apply_results.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Result of applying an operation, can be used for experimenting
    with protocol updates, by clients to print out a summary of the
    operation at pre-injection simulation and at confirmation time,
    and by block explorers. *)

open Alpha_context

(** Result of applying a {!Operation.t}. Follows the same structure. *)
type 'kind operation_metadata = {contents : 'kind contents_result_list}

and packed_operation_metadata =
  | Operation_metadata : 'kind operation_metadata -> packed_operation_metadata
  | No_operation_metadata : packed_operation_metadata

(** Result of applying a {!Operation.contents_list}. Follows the same structure. *)
and 'kind contents_result_list =
  | Single_result : 'kind contents_result -> 'kind contents_result_list
  | Cons_result :
      'kind Kind.manager contents_result
      * 'rest Kind.manager contents_result_list
      -> ('kind * 'rest) Kind.manager contents_result_list

and packed_contents_result_list =
  | Contents_result_list :
      'kind contents_result_list
      -> packed_contents_result_list

(** Result of applying an {!Operation.contents}. Follows the same structure. *)
and 'kind contents_result =
  | Endorsement_result : {
      balance_updates : Delegate.balance_updates;
      delegate : Signature.Public_key_hash.t;
      slots : int list;
    }
      -> Kind.endorsement contents_result
  | Seed_nonce_revelation_result :
      Delegate.balance_updates
      -> Kind.seed_nonce_revelation contents_result
  | Double_endorsement_evidence_result :
      Delegate.balance_updates
      -> Kind.double_endorsement_evidence contents_result
  | Double_baking_evidence_result :
      Delegate.balance_updates
      -> Kind.double_baking_evidence contents_result
  | Activate_account_result :
      Delegate.balance_updates
      -> Kind.activate_account contents_result
  | Proposals_result : Kind.proposals contents_result
  | Ballot_result : Kind.ballot contents_result
  | Manager_operation_result : {
      balance_updates : Delegate.balance_updates;
      operation_result : 'kind manager_operation_result;
      internal_operation_results : packed_internal_operation_result list;
    }
      -> 'kind Kind.manager contents_result

and packed_contents_result =
  | Contents_result : 'kind contents_result -> packed_contents_result

(** The result of an operation in the queue. [Skipped] ones should
    always be at the tail, and after a single [Failed]. *)
and 'kind manager_operation_result =
  | Applied of 'kind successful_manager_operation_result
  | Backtracked of
      'kind successful_manager_operation_result * error list option
  | Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result
  | Skipped : 'kind Kind.manager -> 'kind manager_operation_result

(** Result of applying a {!manager_operation_content}, either internal
    or external. *)
and _ successful_manager_operation_result =
  | Reveal_result : {
      consumed_gas : Z.t;
    }
      -> Kind.reveal successful_manager_operation_result
  | Transaction_result : {
      storage : Script.expr option;
      big_map_diff : Contract.big_map_diff option;
      balance_updates : Delegate.balance_updates;
      originated_contracts : Contract.t list;
      consumed_gas : Z.t;
      storage_size : Z.t;
      paid_storage_size_diff : Z.t;
      allocated_destination_contract : bool;
    }
      -> Kind.transaction successful_manager_operation_result
  | Origination_result : {
      big_map_diff : Contract.big_map_diff option;
      balance_updates : Delegate.balance_updates;
      originated_contracts : Contract.t list;
      consumed_gas : Z.t;
      storage_size : Z.t;
      paid_storage_size_diff : Z.t;
    }
      -> Kind.origination successful_manager_operation_result
  | Delegation_result : {
      consumed_gas : Z.t;
    }
      -> Kind.delegation successful_manager_operation_result

and packed_successful_manager_operation_result =
  | Successful_manager_result :
      'kind successful_manager_operation_result
      -> packed_successful_manager_operation_result

and packed_internal_operation_result =
  | Internal_operation_result :
      'kind internal_operation * 'kind manager_operation_result
      -> packed_internal_operation_result

(** Serializer for {!packed_operation_result}. *)
val operation_metadata_encoding : packed_operation_metadata Data_encoding.t

val operation_data_and_metadata_encoding :
  (Operation.packed_protocol_data * packed_operation_metadata) Data_encoding.t

type 'kind contents_and_result_list =
  | Single_and_result :
      'kind Alpha_context.contents * 'kind contents_result
      -> 'kind contents_and_result_list
  | Cons_and_result :
      'kind Kind.manager Alpha_context.contents
      * 'kind Kind.manager contents_result
      * 'rest Kind.manager contents_and_result_list
      -> ('kind * 'rest) Kind.manager contents_and_result_list

type packed_contents_and_result_list =
  | Contents_and_result_list :
      'kind contents_and_result_list
      -> packed_contents_and_result_list

val contents_and_result_list_encoding :
  packed_contents_and_result_list Data_encoding.t

val pack_contents_list :
  'kind contents_list ->
  'kind contents_result_list ->
  'kind contents_and_result_list

val unpack_contents_list :
  'kind contents_and_result_list ->
  'kind contents_list * 'kind contents_result_list

val to_list : packed_contents_result_list -> packed_contents_result list

val of_list : packed_contents_result list -> packed_contents_result_list

type ('a, 'b) eq = Eq : ('a, 'a) eq

val kind_equal_list :
  'kind contents_list ->
  'kind2 contents_result_list ->
  ('kind, 'kind2) eq option

type block_metadata = {
  baker : Signature.Public_key_hash.t;
  level : Level.t;
  voting_period_kind : Voting_period.kind;
  nonce_hash : Nonce_hash.t option;
  consumed_gas : Z.t;
  deactivated : Signature.Public_key_hash.t list;
  balance_updates : Delegate.balance_updates;
}

val block_metadata_encoding : block_metadata Data_encoding.encoding
Apply_results_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Nonce_hash.

Module contents_result.
  Module Endorsement_result.
    Record record {balance_updates delegate slots : Set} := {
      balance_updates : balance_updates;
      delegate : delegate;
      slots : slots }.
    Arguments record : clear implicits.
  End Endorsement_result.
  Definition Endorsement_result_skeleton := Endorsement_result.record.
  
  Module Manager_operation_result.
    Record record {balance_updates operation_result internal_operation_results :
      Set} := {
      balance_updates : balance_updates;
      operation_result : operation_result;
      internal_operation_results : internal_operation_results }.
    Arguments record : clear implicits.
  End Manager_operation_result.
  Definition Manager_operation_result_skeleton :=
    Manager_operation_result.record.
End contents_result.

Module successful_manager_operation_result.
  Module Reveal_result.
    Record record {consumed_gas : Set} := {
      consumed_gas : consumed_gas }.
    Arguments record : clear implicits.
  End Reveal_result.
  Definition Reveal_result_skeleton := Reveal_result.record.
  
  Module Transaction_result.
    Record record {storage big_map_diff balance_updates originated_contracts
      consumed_gas storage_size paid_storage_size_diff
      allocated_destination_contract : Set} := {
      storage : storage;
      big_map_diff : big_map_diff;
      balance_updates : balance_updates;
      originated_contracts : originated_contracts;
      consumed_gas : consumed_gas;
      storage_size : storage_size;
      paid_storage_size_diff : paid_storage_size_diff;
      allocated_destination_contract : allocated_destination_contract }.
    Arguments record : clear implicits.
  End Transaction_result.
  Definition Transaction_result_skeleton := Transaction_result.record.
  
  Module Origination_result.
    Record record {big_map_diff balance_updates originated_contracts
      consumed_gas storage_size paid_storage_size_diff : Set} := {
      big_map_diff : big_map_diff;
      balance_updates : balance_updates;
      originated_contracts : originated_contracts;
      consumed_gas : consumed_gas;
      storage_size : storage_size;
      paid_storage_size_diff : paid_storage_size_diff }.
    Arguments record : clear implicits.
  End Origination_result.
  Definition Origination_result_skeleton := Origination_result.record.
  
  Module Delegation_result.
    Record record {consumed_gas : Set} := {
      consumed_gas : consumed_gas }.
    Arguments record : clear implicits.
  End Delegation_result.
  Definition Delegation_result_skeleton := Delegation_result.record.
End successful_manager_operation_result.

Module operation_metadata.
  Record record {contents : Set} := Build {
    contents : contents }.
  Arguments record : clear implicits.
  Definition with_contents {t_contents} contents (r : record t_contents) :=
    Build t_contents contents.
End operation_metadata.
Definition operation_metadata_skeleton := operation_metadata.record.

Reserved Notation "'contents_result.Endorsement_result".
Reserved Notation "'contents_result.Manager_operation_result".
Reserved Notation "'successful_manager_operation_result.Reveal_result".
Reserved Notation "'successful_manager_operation_result.Transaction_result".
Reserved Notation "'successful_manager_operation_result.Origination_result".
Reserved Notation "'successful_manager_operation_result.Delegation_result".
Reserved Notation "'operation_metadata".
Reserved Notation "'packed_operation_metadata".
Reserved Notation "'contents_result_list".
Reserved Notation "'packed_contents_result_list".
Reserved Notation "'contents_result".
Reserved Notation "'packed_contents_result".
Reserved Notation "'manager_operation_result".
Reserved Notation "'successful_manager_operation_result".
Reserved Notation "'packed_successful_manager_operation_result".
Reserved Notation "'packed_internal_operation_result".

Inductive packed_operation_metadata_gadt : Set :=
| Operation_metadata : forall {kind : Set},
  'operation_metadata kind -> packed_operation_metadata_gadt
| No_operation_metadata : packed_operation_metadata_gadt

with contents_result_list_gadt : Set :=
| Single_result : forall {kind : Set},
  'contents_result kind -> contents_result_list_gadt
| Cons_result : forall {kind : Set},
  'contents_result (Alpha_context.Kind.manager kind) ->
  contents_result_list_gadt -> contents_result_list_gadt

with packed_contents_result_list_gadt : Set :=
| Contents_result_list : forall {kind : Set},
  'contents_result_list kind -> packed_contents_result_list_gadt

with contents_result_gadt : Set :=
| Endorsement_result :
  'contents_result.Endorsement_result -> contents_result_gadt
| Seed_nonce_revelation_result :
  Alpha_context.Delegate.balance_updates -> contents_result_gadt
| Double_endorsement_evidence_result :
  Alpha_context.Delegate.balance_updates -> contents_result_gadt
| Double_baking_evidence_result :
  Alpha_context.Delegate.balance_updates -> contents_result_gadt
| Activate_account_result :
  Alpha_context.Delegate.balance_updates -> contents_result_gadt
| Proposals_result : contents_result_gadt
| Ballot_result : contents_result_gadt
| Manager_operation_result : forall {kind : Set},
  'contents_result.Manager_operation_result kind -> contents_result_gadt

with packed_contents_result_gadt : Set :=
| Contents_result : forall {kind : Set},
  'contents_result kind -> packed_contents_result_gadt

with manager_operation_result_gadt : Set :=
| Applied : forall {kind : Set},
  'successful_manager_operation_result kind -> manager_operation_result_gadt
| Backtracked : forall {kind : Set},
  'successful_manager_operation_result kind ->
  option (list Error_monad.__error) -> manager_operation_result_gadt
| Failed : forall {kind : Set},
  Alpha_context.Kind.manager kind -> list Error_monad.__error ->
  manager_operation_result_gadt
| Skipped : forall {kind : Set},
  Alpha_context.Kind.manager kind -> manager_operation_result_gadt

with successful_manager_operation_result_gadt : Set :=
| Reveal_result :
  'successful_manager_operation_result.Reveal_result ->
  successful_manager_operation_result_gadt
| Transaction_result :
  'successful_manager_operation_result.Transaction_result ->
  successful_manager_operation_result_gadt
| Origination_result :
  'successful_manager_operation_result.Origination_result ->
  successful_manager_operation_result_gadt
| Delegation_result :
  'successful_manager_operation_result.Delegation_result ->
  successful_manager_operation_result_gadt

with packed_successful_manager_operation_result_gadt : Set :=
| Successful_manager_result : forall {kind : Set},
  'successful_manager_operation_result kind ->
  packed_successful_manager_operation_result_gadt

with packed_internal_operation_result_gadt : Set :=
| Internal_operation_result : forall {kind : Set},
  Alpha_context.internal_operation kind -> 'manager_operation_result kind ->
  packed_internal_operation_result_gadt

where "'operation_metadata" := (fun (t_kind : Set) =>
  operation_metadata_skeleton ('contents_result_list t_kind))
and "'packed_operation_metadata" := (packed_operation_metadata_gadt)
and "'contents_result_list" := (fun (_ : Set) => contents_result_list_gadt)
and "'packed_contents_result_list" := (packed_contents_result_list_gadt)
and "'contents_result" := (fun (_ : Set) => contents_result_gadt)
and "'packed_contents_result" := (packed_contents_result_gadt)
and "'manager_operation_result" := (fun (_ : Set) =>
  manager_operation_result_gadt)
and "'successful_manager_operation_result" := (fun (_ : Set) =>
  successful_manager_operation_result_gadt)
and "'packed_successful_manager_operation_result" :=
  (packed_successful_manager_operation_result_gadt)
and "'packed_internal_operation_result" :=
  (packed_internal_operation_result_gadt)
and "'contents_result.Endorsement_result" :=
  (contents_result.Endorsement_result_skeleton
    Alpha_context.Delegate.balance_updates
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) (list Z))
and "'contents_result.Manager_operation_result" := (fun (t_kind : Set) =>
  contents_result.Manager_operation_result_skeleton
    Alpha_context.Delegate.balance_updates ('manager_operation_result t_kind)
    (list 'packed_internal_operation_result))
and "'successful_manager_operation_result.Reveal_result" :=
  (successful_manager_operation_result.Reveal_result_skeleton Z.t)
and "'successful_manager_operation_result.Transaction_result" :=
  (successful_manager_operation_result.Transaction_result_skeleton
    (option Alpha_context.Script.expr)
    (option Alpha_context.Contract.big_map_diff)
    Alpha_context.Delegate.balance_updates (list Alpha_context.Contract.t) Z.t
    Z.t Z.t bool)
and "'successful_manager_operation_result.Origination_result" :=
  (successful_manager_operation_result.Origination_result_skeleton
    (option Alpha_context.Contract.big_map_diff)
    Alpha_context.Delegate.balance_updates (list Alpha_context.Contract.t) Z.t
    Z.t Z.t)
and "'successful_manager_operation_result.Delegation_result" :=
  (successful_manager_operation_result.Delegation_result_skeleton Z.t).

Module
  ConstructorRecordNotations_packed_operation_metadata_gadt_contents_result_list_gadt_packed_contents_result_list_gadt_contents_result_gadt_packed_contents_result_gadt_manager_operation_result_gadt_successful_manager_operation_result_gadt_packed_successful_manager_operation_result_gadt_packed_internal_operation_result_gadt.
  Module contents_result.
    Definition Endorsement_result := 'contents_result.Endorsement_result.
    Definition Manager_operation_result :=
      'contents_result.Manager_operation_result.
  End contents_result.
  Module successful_manager_operation_result.
    Definition Reveal_result :=
      'successful_manager_operation_result.Reveal_result.
    Definition Transaction_result :=
      'successful_manager_operation_result.Transaction_result.
    Definition Origination_result :=
      'successful_manager_operation_result.Origination_result.
    Definition Delegation_result :=
      'successful_manager_operation_result.Delegation_result.
  End successful_manager_operation_result.
End
  ConstructorRecordNotations_packed_operation_metadata_gadt_contents_result_list_gadt_packed_contents_result_list_gadt_contents_result_gadt_packed_contents_result_gadt_manager_operation_result_gadt_successful_manager_operation_result_gadt_packed_successful_manager_operation_result_gadt_packed_internal_operation_result_gadt.
Import
  ConstructorRecordNotations_packed_operation_metadata_gadt_contents_result_list_gadt_packed_contents_result_list_gadt_contents_result_gadt_packed_contents_result_gadt_manager_operation_result_gadt_successful_manager_operation_result_gadt_packed_successful_manager_operation_result_gadt_packed_internal_operation_result_gadt.

Definition operation_metadata := 'operation_metadata.
Definition packed_operation_metadata := 'packed_operation_metadata.
Definition contents_result_list := 'contents_result_list.
Definition packed_contents_result_list := 'packed_contents_result_list.
Definition contents_result := 'contents_result.
Definition packed_contents_result := 'packed_contents_result.
Definition manager_operation_result := 'manager_operation_result.
Definition successful_manager_operation_result :=
  'successful_manager_operation_result.
Definition packed_successful_manager_operation_result :=
  'packed_successful_manager_operation_result.
Definition packed_internal_operation_result :=
  'packed_internal_operation_result.

Parameter operation_metadata_encoding :
  Data_encoding.t packed_operation_metadata.

Parameter operation_data_and_metadata_encoding :
  Data_encoding.t
    (Alpha_context.Operation.packed_protocol_data * packed_operation_metadata).

Reserved Notation "'contents_and_result_list".

Inductive contents_and_result_list_gadt : Set :=
| Single_and_result : forall {kind : Set},
  Alpha_context.contents kind -> contents_result kind ->
  contents_and_result_list_gadt
| Cons_and_result : forall {kind : Set},
  Alpha_context.contents (Alpha_context.Kind.manager kind) ->
  contents_result (Alpha_context.Kind.manager kind) ->
  contents_and_result_list_gadt -> contents_and_result_list_gadt

where "'contents_and_result_list" := (fun (_ : Set) =>
  contents_and_result_list_gadt).

Definition contents_and_result_list := 'contents_and_result_list.

Reserved Notation "'packed_contents_and_result_list".

Inductive packed_contents_and_result_list_gadt : Set :=
| Contents_and_result_list : forall {kind : Set},
  contents_and_result_list kind -> packed_contents_and_result_list_gadt

where "'packed_contents_and_result_list" :=
  (packed_contents_and_result_list_gadt).

Definition packed_contents_and_result_list := 'packed_contents_and_result_list.

Parameter contents_and_result_list_encoding :
  Data_encoding.t packed_contents_and_result_list.

Parameter pack_contents_list : forall {kind : Set},
  Alpha_context.contents_list kind -> contents_result_list kind ->
  contents_and_result_list kind.

Parameter unpack_contents_list : forall {kind : Set},
  contents_and_result_list kind ->
  Alpha_context.contents_list kind * contents_result_list kind.

Parameter to_list : packed_contents_result_list -> list packed_contents_result.

Parameter of_list : list packed_contents_result -> packed_contents_result_list.

Reserved Notation "'eq".

Inductive eq_gadt : Set :=
| Eq : eq_gadt

where "'eq" := (fun (_ _ : Set) => eq_gadt).

Definition eq := 'eq.

Parameter kind_equal_list : forall {kind kind2 : Set},
  Alpha_context.contents_list kind -> contents_result_list kind2 ->
  option (eq kind kind2).

Module block_metadata.
  Record record := Build {
    baker : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
    level : Alpha_context.Level.t;
    voting_period_kind : Alpha_context.Voting_period.kind;
    nonce_hash : option Nonce_hash.t;
    consumed_gas : Z.t;
    deactivated : list (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
    balance_updates : Alpha_context.Delegate.balance_updates }.
  Definition with_baker baker (r : record) :=
    Build baker r.(level) r.(voting_period_kind) r.(nonce_hash) r.(consumed_gas)
      r.(deactivated) r.(balance_updates).
  Definition with_level level (r : record) :=
    Build r.(baker) level r.(voting_period_kind) r.(nonce_hash) r.(consumed_gas)
      r.(deactivated) r.(balance_updates).
  Definition with_voting_period_kind voting_period_kind (r : record) :=
    Build r.(baker) r.(level) voting_period_kind r.(nonce_hash) r.(consumed_gas)
      r.(deactivated) r.(balance_updates).
  Definition with_nonce_hash nonce_hash (r : record) :=
    Build r.(baker) r.(level) r.(voting_period_kind) nonce_hash r.(consumed_gas)
      r.(deactivated) r.(balance_updates).
  Definition with_consumed_gas consumed_gas (r : record) :=
    Build r.(baker) r.(level) r.(voting_period_kind) r.(nonce_hash) consumed_gas
      r.(deactivated) r.(balance_updates).
  Definition with_deactivated deactivated (r : record) :=
    Build r.(baker) r.(level) r.(voting_period_kind) r.(nonce_hash)
      r.(consumed_gas) deactivated r.(balance_updates).
  Definition with_balance_updates balance_updates (r : record) :=
    Build r.(baker) r.(level) r.(voting_period_kind) r.(nonce_hash)
      r.(consumed_gas) r.(deactivated) balance_updates.
End block_metadata.
Definition block_metadata := block_metadata.record.

Parameter block_metadata_encoding : Data_encoding.encoding block_metadata.

Baking

  • OCaml size: 399 lines
  • Coq size: 447 lines (+12% compared to OCaml)
baking.ml 19 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Misc

type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *)

type error += Timestamp_too_early of Timestamp.t * Timestamp.t

(* `Permanent *)

type error += Unexpected_endorsement (* `Permanent *)

type error +=
  | Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t

(* `Permanent *)

type error += Invalid_signature (* `Permanent *)

type error += Invalid_stamp (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"baking.timestamp_too_early"
    ~title:"Block forged too early"
    ~description:
      "The block timestamp is before the first slot for this baker at this \
       level"
    ~pp:(fun ppf (r, p) ->
      Format.fprintf
        ppf
        "Block forged too early (%a is before %a)"
        Time.pp_hum
        p
        Time.pp_hum
        r)
    Data_encoding.(
      obj2 (req "minimum" Time.encoding) (req "provided" Time.encoding))
    (function Timestamp_too_early (r, p) -> Some (r, p) | _ -> None)
    (fun (r, p) -> Timestamp_too_early (r, p)) ;
  register_error_kind
    `Permanent
    ~id:"baking.invalid_fitness_gap"
    ~title:"Invalid fitness gap"
    ~description:"The gap of fitness is out of bounds"
    ~pp:(fun ppf (m, g) ->
      Format.fprintf ppf "The gap of fitness %Ld is not between 0 and %Ld" g m)
    Data_encoding.(obj2 (req "maximum" int64) (req "provided" int64))
    (function Invalid_fitness_gap (m, g) -> Some (m, g) | _ -> None)
    (fun (m, g) -> Invalid_fitness_gap (m, g)) ;
  register_error_kind
    `Permanent
    ~id:"baking.invalid_block_signature"
    ~title:"Invalid block signature"
    ~description:"A block was not signed with the expected private key."
    ~pp:(fun ppf (block, pkh) ->
      Format.fprintf
        ppf
        "Invalid signature for block %a. Expected: %a."
        Block_hash.pp_short
        block
        Signature.Public_key_hash.pp_short
        pkh)
    Data_encoding.(
      obj2
        (req "block" Block_hash.encoding)
        (req "expected" Signature.Public_key_hash.encoding))
    (function
      | Invalid_block_signature (block, pkh) -> Some (block, pkh) | _ -> None)
    (fun (block, pkh) -> Invalid_block_signature (block, pkh)) ;
  register_error_kind
    `Permanent
    ~id:"baking.invalid_signature"
    ~title:"Invalid block signature"
    ~description:"The block's signature is invalid"
    ~pp:(fun ppf () -> Format.fprintf ppf "Invalid block signature")
    Data_encoding.empty
    (function Invalid_signature -> Some () | _ -> None)
    (fun () -> Invalid_signature) ;
  register_error_kind
    `Permanent
    ~id:"baking.insufficient_proof_of_work"
    ~title:"Insufficient block proof-of-work stamp"
    ~description:"The block's proof-of-work stamp is insufficient"
    ~pp:(fun ppf () -> Format.fprintf ppf "Insufficient proof-of-work stamp")
    Data_encoding.empty
    (function Invalid_stamp -> Some () | _ -> None)
    (fun () -> Invalid_stamp) ;
  register_error_kind
    `Permanent
    ~id:"baking.unexpected_endorsement"
    ~title:"Endorsement from unexpected delegate"
    ~description:
      "The operation is signed by a delegate without endorsement rights."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "The endorsement is signed by a delegate without endorsement rights.")
    Data_encoding.unit
    (function Unexpected_endorsement -> Some () | _ -> None)
    (fun () -> Unexpected_endorsement)

let minimal_time c priority pred_timestamp =
  let priority = Int32.of_int priority in
  let rec cumsum_time_between_blocks acc durations p =
    if Compare.Int32.( <= ) p 0l then ok acc
    else
      match durations with
      | [] ->
          cumsum_time_between_blocks acc [Period.one_minute] p
      | [last] ->
          Period.mult p last >>? fun period -> Timestamp.(acc +? period)
      | first :: durations ->
          Timestamp.(acc +? first)
          >>? fun acc ->
          let p = Int32.pred p in
          cumsum_time_between_blocks acc durations p
  in
  Lwt.return
    (cumsum_time_between_blocks
       pred_timestamp
       (Constants.time_between_blocks c)
       (Int32.succ priority))

let earlier_predecessor_timestamp ctxt level =
  let current = Level.current ctxt in
  let current_timestamp = Timestamp.current ctxt in
  let gap = Level.diff level current in
  let step = List.hd (Constants.time_between_blocks ctxt) in
  if Compare.Int32.(gap < 1l) then
    failwith "Baking.earlier_block_timestamp: past block."
  else
    Lwt.return (Period.mult (Int32.pred gap) step)
    >>=? fun delay ->
    Lwt.return Timestamp.(current_timestamp +? delay)
    >>=? fun result -> return result

let check_timestamp c priority pred_timestamp =
  minimal_time c priority pred_timestamp
  >>=? fun minimal_time ->
  let timestamp = Alpha_context.Timestamp.current c in
  Lwt.return
    (record_trace
       (Timestamp_too_early (minimal_time, timestamp))
       Timestamp.(timestamp -? minimal_time))

let check_baking_rights c {Block_header.priority; _} pred_timestamp =
  let level = Level.current c in
  Roll.baking_rights_owner c level ~priority
  >>=? fun delegate ->
  check_timestamp c priority pred_timestamp
  >>=? fun block_delay -> return (delegate, block_delay)

type error += Incorrect_priority (* `Permanent *)

type error += Incorrect_number_of_endorsements (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"incorrect_priority"
    ~title:"Incorrect priority"
    ~description:"Block priority must be non-negative."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "The block priority must be non-negative.")
    Data_encoding.unit
    (function Incorrect_priority -> Some () | _ -> None)
    (fun () -> Incorrect_priority)

let () =
  let description =
    "The number of endorsements must be non-negative and at most the \
     endosers_per_block constant."
  in
  register_error_kind
    `Permanent
    ~id:"incorrect_number_of_endorsements"
    ~title:"Incorrect number of endorsements"
    ~description
    ~pp:(fun ppf () -> Format.fprintf ppf "%s" description)
    Data_encoding.unit
    (function Incorrect_number_of_endorsements -> Some () | _ -> None)
    (fun () -> Incorrect_number_of_endorsements)

let baking_reward ctxt ~block_priority:prio ~included_endorsements:num_endo =
  fail_unless Compare.Int.(prio >= 0) Incorrect_priority
  >>=? fun () ->
  let max_endorsements = Constants.endorsers_per_block ctxt in
  fail_unless
    Compare.Int.(num_endo >= 0 && num_endo <= max_endorsements)
    Incorrect_number_of_endorsements
  >>=? fun () ->
  let prio_factor_denominator = Int64.(succ (of_int prio)) in
  let endo_factor_numerator =
    Int64.of_int (8 + (2 * num_endo / max_endorsements))
  in
  let endo_factor_denominator = 10L in
  Lwt.return
    Tez.(
      Constants.block_reward ctxt *? endo_factor_numerator
      >>? fun val1 ->
      val1 /? endo_factor_denominator
      >>? fun val2 -> val2 /? prio_factor_denominator)

let endorsing_reward ctxt ~block_priority:prio n =
  if Compare.Int.(prio >= 0) then
    Lwt.return
      Tez.(Constants.endorsement_reward ctxt /? Int64.(succ (of_int prio)))
    >>=? fun tez -> Lwt.return Tez.(tez *? Int64.of_int n)
  else fail Incorrect_priority

let baking_priorities c level =
  let rec f priority =
    Roll.baking_rights_owner c level ~priority
    >>=? fun delegate -> return (LCons (delegate, fun () -> f (succ priority)))
  in
  f 0

let endorsement_rights c level =
  fold_left_s
    (fun acc slot ->
      Roll.endorsement_rights_owner c level ~slot
      >>=? fun pk ->
      let pkh = Signature.Public_key.hash pk in
      let right =
        match Signature.Public_key_hash.Map.find_opt pkh acc with
        | None ->
            (pk, [slot], false)
        | Some (pk, slots, used) ->
            (pk, slot :: slots, used)
      in
      return (Signature.Public_key_hash.Map.add pkh right acc))
    Signature.Public_key_hash.Map.empty
    (0 --> (Constants.endorsers_per_block c - 1))

let check_endorsement_rights ctxt chain_id (op : Kind.endorsement Operation.t)
    =
  let current_level = Level.current ctxt in
  let (Single (Endorsement {level; _})) = op.protocol_data.contents in
  ( if Raw_level.(succ level = current_level.level) then
    return (Alpha_context.allowed_endorsements ctxt)
  else endorsement_rights ctxt (Level.from_raw ctxt level) )
  >>=? fun endorsements ->
  match
    Signature.Public_key_hash.Map.fold (* no find_first *)
      (fun pkh (pk, slots, used) acc ->
        match Operation.check_signature_sync pk chain_id op with
        | Error _ ->
            acc
        | Ok () ->
            Some (pkh, slots, used))
      endorsements
      None
  with
  | None ->
      fail Unexpected_endorsement
  | Some v ->
      return v

let select_delegate delegate delegate_list max_priority =
  let rec loop acc l n =
    if Compare.Int.(n >= max_priority) then return (List.rev acc)
    else
      let (LCons (pk, t)) = l in
      let acc =
        if
          Signature.Public_key_hash.equal
            delegate
            (Signature.Public_key.hash pk)
        then n :: acc
        else acc
      in
      t () >>=? fun t -> loop acc t (succ n)
  in
  loop [] delegate_list 0

let first_baking_priorities ctxt ?(max_priority = 32) delegate level =
  baking_priorities ctxt level
  >>=? fun delegate_list -> select_delegate delegate delegate_list max_priority

let check_hash hash stamp_threshold =
  let bytes = Block_hash.to_bytes hash in
  let word = MBytes.get_int64 bytes 0 in
  Compare.Uint64.(word <= stamp_threshold)

let check_header_proof_of_work_stamp shell contents stamp_threshold =
  let hash =
    Block_header.hash
      {shell; protocol_data = {contents; signature = Signature.zero}}
  in
  check_hash hash stamp_threshold

let check_proof_of_work_stamp ctxt block =
  let proof_of_work_threshold = Constants.proof_of_work_threshold ctxt in
  if
    check_header_proof_of_work_stamp
      block.Block_header.shell
      block.protocol_data.contents
      proof_of_work_threshold
  then return_unit
  else fail Invalid_stamp

let check_signature block chain_id key =
  let check_signature key
      {Block_header.shell; protocol_data = {contents; signature}} =
    let unsigned_header =
      Data_encoding.Binary.to_bytes_exn
        Block_header.unsigned_encoding
        (shell, contents)
    in
    Signature.check
      ~watermark:(Block_header chain_id)
      key
      signature
      unsigned_header
  in
  if check_signature key block then return_unit
  else
    fail
      (Invalid_block_signature
         (Block_header.hash block, Signature.Public_key.hash key))

let max_fitness_gap _ctxt = 1L

let check_fitness_gap ctxt (block : Block_header.t) =
  let current_fitness = Fitness.current ctxt in
  Lwt.return (Fitness.to_int64 block.shell.fitness)
  >>=? fun announced_fitness ->
  let gap = Int64.sub announced_fitness current_fitness in
  if Compare.Int64.(gap <= 0L || max_fitness_gap ctxt < gap) then
    fail (Invalid_fitness_gap (max_fitness_gap ctxt, gap))
  else return_unit

let last_of_a_cycle ctxt l =
  Compare.Int32.(
    Int32.succ l.Level.cycle_position = Constants.blocks_per_cycle ctxt)

let dawn_of_a_new_cycle ctxt =
  let level = Level.current ctxt in
  if last_of_a_cycle ctxt level then return_some level.cycle else return_none

let minimum_allowed_endorsements ctxt ~block_delay =
  let minimum = Constants.initial_endorsers ctxt in
  let delay_per_missing_endorsement =
    Int64.to_int
      (Period.to_seconds (Constants.delay_per_missing_endorsement ctxt))
  in
  let reduced_time_constraint =
    let delay = Int64.to_int (Period.to_seconds block_delay) in
    if Compare.Int.(delay_per_missing_endorsement = 0) then delay
    else delay / delay_per_missing_endorsement
  in
  Compare.Int.max 0 (minimum - reduced_time_constraint)

let minimal_valid_time ctxt ~priority ~endorsing_power =
  let predecessor_timestamp = Timestamp.current ctxt in
  minimal_time ctxt priority predecessor_timestamp
  >>=? fun minimal_time ->
  let minimal_required_endorsements = Constants.initial_endorsers ctxt in
  let delay_per_missing_endorsement =
    Constants.delay_per_missing_endorsement ctxt
  in
  let missing_endorsements =
    Compare.Int.max 0 (minimal_required_endorsements - endorsing_power)
  in
  match
    Period.mult
      (Int32.of_int missing_endorsements)
      delay_per_missing_endorsement
  with
  | Ok delay ->
      return (Time.add minimal_time (Period.to_seconds delay))
  | Error _ as err ->
      Lwt.return err
Baking.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Misc.

Import Alpha_context.

Import Misc.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition minimal_time
  (c : Alpha_context.context) (priority : Z)
  (pred_timestamp : Alpha_context.Timestamp.time)
  : Lwt.t (Error_monad.tzresult Alpha_context.Timestamp.time) :=
  let priority := Int32.of_int priority in
  let fix cumsum_time_between_blocks
    (acc : Alpha_context.Timestamp.time)
    (durations : list Alpha_context.Period.period)
    (p : (|Compare.Int32|).(Compare.S.t)) {struct acc}
    : Error_monad.tzresult Alpha_context.Timestamp.time :=
    if
      (|Compare.Int32|).(Compare.S.op_lteq) p
        (* ❌ Constant of type int32 is converted to int *)
        0 then
      Error_monad.ok acc
    else
      match durations with
      | [] =>
        cumsum_time_between_blocks acc [ Alpha_context.Period.one_minute ] p
      | cons last [] =>
        Error_monad.op_gtgtquestion (Alpha_context.Period.mult p last)
          (fun period => Alpha_context.Timestamp.op_plusquestion acc period)
      | cons first durations =>
        Error_monad.op_gtgtquestion
          (Alpha_context.Timestamp.op_plusquestion acc first)
          (fun acc =>
            let p := Int32.pred p in
            cumsum_time_between_blocks acc durations p)
      end in
  Lwt.__return
    (cumsum_time_between_blocks pred_timestamp
      (Alpha_context.Constants.time_between_blocks c) (Int32.succ priority)).

Definition earlier_predecessor_timestamp
  (ctxt : Alpha_context.context) (level : Alpha_context.Level.level)
  : Lwt.t (Error_monad.tzresult Alpha_context.Timestamp.time) :=
  let current := Alpha_context.Level.current ctxt in
  let current_timestamp := Alpha_context.Timestamp.current ctxt in
  let gap := Alpha_context.Level.diff level current in
  let step := List.hd (Alpha_context.Constants.time_between_blocks ctxt) in
  if
    (|Compare.Int32|).(Compare.S.op_lt) gap
      (* ❌ Constant of type int32 is converted to int *)
      1 then
    Pervasives.failwith "Baking.earlier_block_timestamp: past block."
  else
    Error_monad.op_gtgteqquestion
      (Lwt.__return (Alpha_context.Period.mult (Int32.pred gap) step))
      (fun delay =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Timestamp.op_plusquestion current_timestamp delay))
          (fun __result_value => Error_monad.__return __result_value)).

Definition check_timestamp
  (c : Alpha_context.context) (priority : Z)
  (pred_timestamp : Alpha_context.Timestamp.time)
  : Lwt.t (Error_monad.tzresult Alpha_context.Period.t) :=
  Error_monad.op_gtgteqquestion (minimal_time c priority pred_timestamp)
    (fun minimal_time =>
      let timestamp := Alpha_context.Timestamp.current c in
      Lwt.__return
        (Error_monad.record_trace extensible_type_value
          (Alpha_context.Timestamp.op_minusquestion timestamp minimal_time))).

Definition check_baking_rights
  (c : Alpha_context.context)
  (function_parameter : Alpha_context.Block_header.contents)
  : Alpha_context.Timestamp.time ->
  Lwt.t
    (Error_monad.tzresult (Alpha_context.public_key * Alpha_context.Period.t)) :=
  let '{| Alpha_context.Block_header.contents.priority := priority |} :=
    function_parameter in
  fun pred_timestamp =>
    let level := Alpha_context.Level.current c in
    Error_monad.op_gtgteqquestion
      (Alpha_context.Roll.baking_rights_owner c level priority)
      (fun delegate =>
        Error_monad.op_gtgteqquestion
          (check_timestamp c priority pred_timestamp)
          (fun block_delay => Error_monad.__return (delegate, block_delay))).

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition baking_reward
  (ctxt : Alpha_context.context) (prio : (|Compare.Int|).(Compare.S.t))
  (num_endo : (|Compare.Int|).(Compare.S.t))
  : Lwt.t (Error_monad.tzresult Alpha_context.Tez.tez) :=
  Error_monad.op_gtgteqquestion
    (Error_monad.fail_unless ((|Compare.Int|).(Compare.S.op_gteq) prio 0)
      extensible_type_value)
    (fun function_parameter =>
      let '_ := function_parameter in
      let max_endorsements := Alpha_context.Constants.endorsers_per_block ctxt
        in
      Error_monad.op_gtgteqquestion
        (Error_monad.fail_unless
          (Pervasives.op_andand ((|Compare.Int|).(Compare.S.op_gteq) num_endo 0)
            ((|Compare.Int|).(Compare.S.op_lteq) num_endo max_endorsements))
          extensible_type_value)
        (fun function_parameter =>
          let '_ := function_parameter in
          let prio_factor_denominator := Int64.succ (Int64.of_int prio) in
          let endo_factor_numerator :=
            Int64.of_int
              (Pervasives.op_plus 8
                (Pervasives.op_div (Pervasives.op_star 2 num_endo)
                  max_endorsements)) in
          let endo_factor_denominator :=
            (* ❌ Constant of type int64 is converted to int *)
            10 in
          Lwt.__return
            (Error_monad.op_gtgtquestion
              (Alpha_context.Tez.op_starquestion
                (Alpha_context.Constants.block_reward ctxt)
                endo_factor_numerator)
              (fun val1 =>
                Error_monad.op_gtgtquestion
                  (Alpha_context.Tez.op_divquestion val1 endo_factor_denominator)
                  (fun val2 =>
                    Alpha_context.Tez.op_divquestion val2
                      prio_factor_denominator))))).

Definition endorsing_reward
  (ctxt : Alpha_context.context) (prio : (|Compare.Int|).(Compare.S.t)) (n : Z)
  : Lwt.t (Error_monad.tzresult Alpha_context.Tez.tez) :=
  if (|Compare.Int|).(Compare.S.op_gteq) prio 0 then
    Error_monad.op_gtgteqquestion
      (Lwt.__return
        (Alpha_context.Tez.op_divquestion
          (Alpha_context.Constants.endorsement_reward ctxt)
          (Int64.succ (Int64.of_int prio))))
      (fun tez =>
        Lwt.__return (Alpha_context.Tez.op_starquestion tez (Int64.of_int n)))
  else
    Error_monad.fail extensible_type_value.

Definition baking_priorities
  (c : Alpha_context.context) (level : Alpha_context.Level.t)
  : Lwt.t (Error_monad.tzresult (Misc.lazy_list_t Alpha_context.public_key)) :=
  let fix f (priority : Z) {struct priority}
    : Lwt.t (Error_monad.tzresult (Misc.lazy_list_t Alpha_context.public_key)) :=
    Error_monad.op_gtgteqquestion
      (Alpha_context.Roll.baking_rights_owner c level priority)
      (fun delegate =>
        Error_monad.__return
          (Misc.LCons delegate
            (fun function_parameter =>
              let '_ := function_parameter in
              f (Pervasives.succ priority)))) in
  f 0.

Definition endorsement_rights
  (c : Alpha_context.context) (level : Alpha_context.Level.t)
  : Lwt.t
    (Error_monad.tzresult
      ((|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.t)
        (Alpha_context.public_key * list Z * bool))) :=
  Error_monad.fold_left_s
    (fun acc =>
      fun slot =>
        Error_monad.op_gtgteqquestion
          (Alpha_context.Roll.endorsement_rights_owner c level slot)
          (fun pk =>
            let pkh := (|Signature.Public_key|).(S.SPublic_key.__hash_value) pk
              in
            let __right :=
              match
                (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.find_opt)
                  pkh acc with
              | None => (pk, [ slot ], false)
              | Some (pk, slots, used) => (pk, (cons slot slots), used)
              end in
            Error_monad.__return
              ((|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.add)
                pkh __right acc)))
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.empty)
    (Misc.op_minusminusgt 0
      (Pervasives.op_minus (Alpha_context.Constants.endorsers_per_block c) 1)).

Definition check_endorsement_rights
  (ctxt : Alpha_context.context) (chain_id : (|Chain_id|).(S.HASH.t))
  (op : Alpha_context.Operation.t Alpha_context.Kind.endorsement)
  : Lwt.t
    (Error_monad.tzresult
      ((|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.key)
        * list Z * bool)) :=
  let current_level := Alpha_context.Level.current ctxt in
  let
    'Alpha_context.Single
      (Alpha_context.Endorsement {|
        Alpha_context.contents.Endorsement.level := level |}) :=
    Alpha_context.protocol_data.contents
      (Alpha_context.operation.protocol_data op) in
  Error_monad.op_gtgteqquestion
    (if
      Alpha_context.Raw_level.op_eq (Alpha_context.Raw_level.succ level)
        (Alpha_context.Level.t.level current_level) then
      Error_monad.__return (Alpha_context.allowed_endorsements ctxt)
    else
      endorsement_rights ctxt (Alpha_context.Level.from_raw ctxt None level))
    (fun endorsements =>
      match
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.fold)
          (fun pkh =>
            fun function_parameter =>
              let '(pk, slots, used) := function_parameter in
              fun acc =>
                match
                  Alpha_context.Operation.check_signature_sync pk chain_id op
                  with
                | Pervasives.Error _ => acc
                | Pervasives.Ok _ => Some (pkh, slots, used)
                end) endorsements None with
      | None => Error_monad.fail extensible_type_value
      | Some v => Error_monad.__return v
      end).

Definition select_delegate
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (delegate_list : Misc.lazy_list_t (|Signature.Public_key|).(S.SPublic_key.t))
  (max_priority : (|Compare.Int|).(Compare.S.t))
  : Lwt.t (Error_monad.tzresult (list (|Compare.Int|).(Compare.S.t))) :=
  let fix loop
    (acc : list (|Compare.Int|).(Compare.S.t))
    (l : Misc.lazy_list_t (|Signature.Public_key|).(S.SPublic_key.t))
    (n : (|Compare.Int|).(Compare.S.t)) {struct acc}
    : Lwt.t (Error_monad.tzresult (list (|Compare.Int|).(Compare.S.t))) :=
    if (|Compare.Int|).(Compare.S.op_gteq) n max_priority then
      Error_monad.__return (List.rev acc)
    else
      let 'Misc.LCons pk __t_value := l in
      let acc :=
        if
          (|Signature.Public_key_hash|).(S.SPublic_key_hash.equal) delegate
            ((|Signature.Public_key|).(S.SPublic_key.__hash_value) pk) then
          cons n acc
        else
          acc in
      Error_monad.op_gtgteqquestion (__t_value tt)
        (fun __t_value => loop acc __t_value (Pervasives.succ n)) in
  loop [] delegate_list 0.

Definition first_baking_priorities
  (ctxt : Alpha_context.context)
  (op_staroptstar : option (|Compare.Int|).(Compare.S.t))
  : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Alpha_context.Level.t ->
  Lwt.t (Error_monad.tzresult (list (|Compare.Int|).(Compare.S.t))) :=
  let max_priority :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 32
    end in
  fun delegate =>
    fun level =>
      Error_monad.op_gtgteqquestion (baking_priorities ctxt level)
        (fun delegate_list =>
          select_delegate delegate delegate_list max_priority).

Definition check_hash
  (__hash_value : (|Block_hash|).(S.HASH.t))
  (stamp_threshold : (|Compare.Uint64|).(Compare.S.t)) : bool :=
  let __bytes_value := (|Block_hash|).(S.HASH.to_bytes) __hash_value in
  let word := MBytes.get_int64 __bytes_value 0 in
  (|Compare.Uint64|).(Compare.S.op_lteq) word stamp_threshold.

Definition check_header_proof_of_work_stamp
  (shell : Block_header.shell_header)
  (contents : Alpha_context.Block_header.contents)
  (stamp_threshold : (|Compare.Uint64|).(Compare.S.t)) : bool :=
  let __hash_value :=
    Alpha_context.Block_header.__hash_value
      {| Alpha_context.Block_header.t.shell := shell;
        Alpha_context.Block_header.t.protocol_data :=
          {| Alpha_context.Block_header.protocol_data.contents := contents;
            Alpha_context.Block_header.protocol_data.signature := Signature.zero
            |} |} in
  check_hash __hash_value stamp_threshold.

Definition check_proof_of_work_stamp
  (ctxt : Alpha_context.context) (block : Alpha_context.Block_header.t)
  : Lwt.t (Error_monad.tzresult unit) :=
  let proof_of_work_threshold :=
    Alpha_context.Constants.proof_of_work_threshold ctxt in
  if
    check_header_proof_of_work_stamp (Alpha_context.Block_header.t.shell block)
      (Alpha_context.Block_header.protocol_data.contents
        (Alpha_context.Block_header.t.protocol_data block))
      proof_of_work_threshold then
    Error_monad.return_unit
  else
    Error_monad.fail extensible_type_value.

Definition check_signature
  (block : Alpha_context.Block_header.t) (chain_id : (|Chain_id|).(S.HASH.t))
  (key : (|Signature.Public_key|).(S.SPublic_key.t))
  : Lwt.t (Error_monad.tzresult unit) :=
  let check_signature
    (key : (|Signature.Public_key|).(S.SPublic_key.t))
    (function_parameter : Alpha_context.Block_header.t) : bool :=
    let '{|
      Alpha_context.Block_header.t.shell := shell;
        Alpha_context.Block_header.t.protocol_data := {|
          Alpha_context.Block_header.protocol_data.contents := contents;
            Alpha_context.Block_header.protocol_data.signature :=
              signature
            |}
        |} := function_parameter in
    let unsigned_header :=
      Data_encoding.Binary.to_bytes_exn
        Alpha_context.Block_header.unsigned_encoding (shell, contents) in
    Signature.check (Some (Signature.Block_header chain_id)) key signature
      unsigned_header in
  if check_signature key block then
    Error_monad.return_unit
  else
    Error_monad.fail extensible_type_value.

Definition max_fitness_gap {A : Set} (_ctxt : A) : int64 :=
  (* ❌ Constant of type int64 is converted to int *)
  1.

Definition check_fitness_gap
  (ctxt : Alpha_context.context) (block : Alpha_context.Block_header.t)
  : Lwt.t (Error_monad.tzresult unit) :=
  let current_fitness := Alpha_context.Fitness.current ctxt in
  Error_monad.op_gtgteqquestion
    (Lwt.__return
      (Alpha_context.Fitness.to_int64
        (Block_header.shell_header.fitness
          (Alpha_context.Block_header.t.shell block))))
    (fun announced_fitness =>
      let gap := Int64.sub announced_fitness current_fitness in
      if
        Pervasives.op_pipepipe
          ((|Compare.Int64|).(Compare.S.op_lteq) gap
            (* ❌ Constant of type int64 is converted to int *)
            0) ((|Compare.Int64|).(Compare.S.op_lt) (max_fitness_gap ctxt) gap)
        then
        Error_monad.fail extensible_type_value
      else
        Error_monad.return_unit).

Definition last_of_a_cycle
  (ctxt : Alpha_context.context) (l : Alpha_context.Level.t) : bool :=
  (|Compare.Int32|).(Compare.S.op_eq)
    (Int32.succ (Alpha_context.Level.t.cycle_position l))
    (Alpha_context.Constants.blocks_per_cycle ctxt).

Definition dawn_of_a_new_cycle (ctxt : Alpha_context.context)
  : Lwt.t (Error_monad.tzresult (option Alpha_context.Cycle.t)) :=
  let level := Alpha_context.Level.current ctxt in
  if last_of_a_cycle ctxt level then
    Error_monad.return_some (Alpha_context.Level.t.cycle level)
  else
    Error_monad.return_none.

Definition minimum_allowed_endorsements
  (ctxt : Alpha_context.context) (block_delay : Alpha_context.Period.period)
  : (|Compare.Int|).(Compare.S.t) :=
  let minimum := Alpha_context.Constants.initial_endorsers ctxt in
  let delay_per_missing_endorsement :=
    Int64.to_int
      (Alpha_context.Period.to_seconds
        (Alpha_context.Constants.delay_per_missing_endorsement ctxt)) in
  let reduced_time_constraint :=
    let delay := Int64.to_int (Alpha_context.Period.to_seconds block_delay) in
    if (|Compare.Int|).(Compare.S.op_eq) delay_per_missing_endorsement 0 then
      delay
    else
      Pervasives.op_div delay delay_per_missing_endorsement in
  (|Compare.Int|).(Compare.S.max) 0
    (Pervasives.op_minus minimum reduced_time_constraint).

Definition minimal_valid_time
  (ctxt : Alpha_context.context) (priority : Z) (endorsing_power : Z)
  : Lwt.t (Error_monad.tzresult Time.t) :=
  let predecessor_timestamp := Alpha_context.Timestamp.current ctxt in
  Error_monad.op_gtgteqquestion
    (minimal_time ctxt priority predecessor_timestamp)
    (fun minimal_time =>
      let minimal_required_endorsements :=
        Alpha_context.Constants.initial_endorsers ctxt in
      let delay_per_missing_endorsement :=
        Alpha_context.Constants.delay_per_missing_endorsement ctxt in
      let missing_endorsements :=
        (|Compare.Int|).(Compare.S.max) 0
          (Pervasives.op_minus minimal_required_endorsements endorsing_power) in
      match
        Alpha_context.Period.mult (Int32.of_int missing_endorsements)
          delay_per_missing_endorsement with
      | Pervasives.Ok delay =>
        Error_monad.__return
          (Time.add minimal_time (Alpha_context.Period.to_seconds delay))
      | (Pervasives.Error _) as err => Lwt.__return err
      end).

Baking_mli

  • OCaml size: 165 lines
  • Coq size: 92 lines (-45% compared to OCaml)
baking.mli 6 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Misc

type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *)

type error += Timestamp_too_early of Timestamp.t * Timestamp.t

(* `Permanent *)

type error +=
  | Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t

(* `Permanent *)

type error += Unexpected_endorsement

type error += Invalid_signature (* `Permanent *)

type error += Invalid_stamp (* `Permanent *)

(** [minimal_time ctxt priority pred_block_time] returns the minimal
    time, given the predecessor block timestamp [pred_block_time],
    after which a baker with priority [priority] is allowed to
    bake. Fail with [Invalid_time_between_blocks_constant] if the minimal
    time cannot be computed. *)
val minimal_time : context -> int -> Time.t -> Time.t tzresult Lwt.t

(** [check_baking_rights ctxt block pred_timestamp] verifies that:
    * the contract that owned the roll at cycle start has the block signer as delegate.
    * the timestamp is coherent with the announced slot.
*)
val check_baking_rights :
  context ->
  Block_header.contents ->
  Time.t ->
  (public_key * Period.t) tzresult Lwt.t

(** For a given level computes who has the right to
    include an endorsement in the next block.
    The result can be stored in Alpha_context.allowed_endorsements *)
val endorsement_rights :
  context ->
  Level.t ->
  (public_key * int list * bool) Signature.Public_key_hash.Map.t tzresult Lwt.t

(** Check that the operation was signed by a delegate allowed
    to endorse at the level specified by the endorsement. *)
val check_endorsement_rights :
  context ->
  Chain_id.t ->
  Kind.endorsement Operation.t ->
  (public_key_hash * int list * bool) tzresult Lwt.t

(** Returns the baking reward calculated w.r.t a given priority [p] and a
    number [e] of included endorsements as follows:
      (block_reward / (p+1)) * (0.8 + 0.2 * e / endorsers_per_block)
*)
val baking_reward :
  context ->
  block_priority:int ->
  included_endorsements:int ->
  Tez.t tzresult Lwt.t

(** Returns the endorsing reward calculated w.r.t a given priority.  *)
val endorsing_reward :
  context -> block_priority:int -> int -> Tez.t tzresult Lwt.t

(** [baking_priorities ctxt level] is the lazy list of contract's
    public key hashes that are allowed to bake for [level]. *)
val baking_priorities : context -> Level.t -> public_key lazy_list

(** [first_baking_priorities ctxt ?max_priority contract_hash level]
    is a list of priorities of max [?max_priority] elements, where the
    delegate of [contract_hash] is allowed to bake for [level]. If
    [?max_priority] is [None], a sensible number of priorities is
    returned. *)
val first_baking_priorities :
  context ->
  ?max_priority:int ->
  public_key_hash ->
  Level.t ->
  int list tzresult Lwt.t

(** [check_signature ctxt chain_id block id] check if the block is
    signed with the given key, and belongs to the given [chain_id] *)
val check_signature :
  Block_header.t -> Chain_id.t -> public_key -> unit tzresult Lwt.t

(** Checks if the header that would be built from the given components
    is valid for the given diffculty. The signature is not passed as it
    is does not impact the proof-of-work stamp. The stamp is checked on
    the hash of a block header whose signature has been zeroed-out. *)
val check_header_proof_of_work_stamp :
  Block_header.shell_header -> Block_header.contents -> int64 -> bool

(** verify if the proof of work stamp is valid *)
val check_proof_of_work_stamp :
  context -> Block_header.t -> unit tzresult Lwt.t

(** check if the gap between the fitness of the current context
    and the given block is within the protocol parameters *)
val check_fitness_gap : context -> Block_header.t -> unit tzresult Lwt.t

val dawn_of_a_new_cycle : context -> Cycle.t option tzresult Lwt.t

val earlier_predecessor_timestamp :
  context -> Level.t -> Timestamp.t tzresult Lwt.t

(** Since Emmy+

    A block is valid only if its timestamp has a minimal delay with
    respect to the previous block's timestamp, and this minimal delay
    depends not only on the block's priority but also on the number of
    endorsement operations included in the block.

    In Emmy+, blocks' fitness increases by one unit with each level.

    In this way, Emmy+ simplifies the optimal baking strategy: The
    bakers used to have to choose whether to wait for more endorsements
    to include in their block, or to publish the block immediately,
    without waiting. The incentive for including more endorsements was
    to increase the fitness and win against unknown blocks. However,
    when a block was produced too late in the priority period, there
    was the risk that the block did not reach endorsers before the
    block of next priority. In Emmy+, the baker does not need to take
    such a decision, because the baker cannot publish a block too
    early. *)

(** Given a delay of a block's timestamp with respect to the minimum
    time to bake at the block's priority (as returned by
    `minimum_time`), it returns the minimum number of endorsements that
    the block has to contain *)
val minimum_allowed_endorsements : context -> block_delay:Period.t -> int

(** This is the somehow the dual of the previous function. Given a
    block priority and a number of endorsement slots (given by the
    `endorsing_power` argument), it returns the minimum time at which
    the next block can be baked. *)
val minimal_valid_time :
  context -> priority:int -> endorsing_power:int -> Time.t tzresult Lwt.t
Baking_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Misc.

(* extensible_type error *)

(* extensible_type error *)

(* extensible_type error *)

(* extensible_type error *)

(* extensible_type error *)

(* extensible_type error *)

Parameter minimal_time :
  Alpha_context.context -> Z -> Time.t -> Lwt.t (Error_monad.tzresult Time.t).

Parameter check_baking_rights :
  Alpha_context.context -> Alpha_context.Block_header.contents -> Time.t ->
  Lwt.t
    (Error_monad.tzresult (Alpha_context.public_key * Alpha_context.Period.t)).

Parameter endorsement_rights :
  Alpha_context.context -> Alpha_context.Level.t ->
  Lwt.t
    (Error_monad.tzresult
      ((|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.t)
        (Alpha_context.public_key * list Z * bool))).

Parameter check_endorsement_rights :
  Alpha_context.context -> (|Chain_id|).(S.HASH.t) ->
  Alpha_context.Operation.t Alpha_context.Kind.endorsement ->
  Lwt.t (Error_monad.tzresult (Alpha_context.public_key_hash * list Z * bool)).

Parameter baking_reward :
  Alpha_context.context -> Z -> Z ->
  Lwt.t (Error_monad.tzresult Alpha_context.Tez.t).

Parameter endorsing_reward :
  Alpha_context.context -> Z -> Z ->
  Lwt.t (Error_monad.tzresult Alpha_context.Tez.t).

Parameter baking_priorities :
  Alpha_context.context -> Alpha_context.Level.t ->
  Misc.lazy_list Alpha_context.public_key.

Parameter first_baking_priorities :
  Alpha_context.context -> option Z -> Alpha_context.public_key_hash ->
  Alpha_context.Level.t -> Lwt.t (Error_monad.tzresult (list Z)).

Parameter check_signature :
  Alpha_context.Block_header.t -> (|Chain_id|).(S.HASH.t) ->
  Alpha_context.public_key -> Lwt.t (Error_monad.tzresult unit).

Parameter check_header_proof_of_work_stamp :
  Alpha_context.Block_header.shell_header ->
  Alpha_context.Block_header.contents -> int64 -> bool.

Parameter check_proof_of_work_stamp :
  Alpha_context.context -> Alpha_context.Block_header.t ->
  Lwt.t (Error_monad.tzresult unit).

Parameter check_fitness_gap :
  Alpha_context.context -> Alpha_context.Block_header.t ->
  Lwt.t (Error_monad.tzresult unit).

Parameter dawn_of_a_new_cycle :
  Alpha_context.context ->
  Lwt.t (Error_monad.tzresult (option Alpha_context.Cycle.t)).

Parameter earlier_predecessor_timestamp :
  Alpha_context.context -> Alpha_context.Level.t ->
  Lwt.t (Error_monad.tzresult Alpha_context.Timestamp.t).

Parameter minimum_allowed_endorsements :
  Alpha_context.context -> Alpha_context.Period.t -> Z.

Parameter minimal_valid_time :
  Alpha_context.context -> Z -> Z -> Lwt.t (Error_monad.tzresult Time.t).

Blinded_public_key_hash

  • OCaml size: 57 lines
  • Coq size: 131 lines (+129% compared to OCaml)
blinded_public_key_hash.ml 3 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module H =
  Blake2B.Make
    (Base58)
    (struct
      let name = "Blinded public key hash"

      let title = "A blinded public key hash"

      let b58check_prefix = "\001\002\049\223"

      let size = Some Ed25519.Public_key_hash.size
    end)

include H

let () = Base58.check_encoded_prefix b58check_encoding "btz1" 37

let of_ed25519_pkh activation_code pkh =
  hash_bytes ~key:activation_code [Ed25519.Public_key_hash.to_bytes pkh]

type activation_code = MBytes.t

let activation_code_size = Ed25519.Public_key_hash.size

let activation_code_encoding = Data_encoding.Fixed.bytes activation_code_size

let activation_code_of_hex h =
  if Compare.Int.(String.length h <> activation_code_size * 2) then
    invalid_arg "Blinded_public_key_hash.activation_code_of_hex" ;
  MBytes.of_hex (`Hex h)

module Index = H
Blinded_public_key_hash.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Definition H :=
  (Blake2B.Make
    (existT (fun _ => _) tt
      {|
        Blake2B.SRegister.register_encoding {_} := Base58.register_encoding
      |}))
    (let name := "Blinded public key hash" in
    let title := "A blinded public key hash" in
    let b58check_prefix := "\001\0021\223" in
    let size :=
      Some (|Ed25519|).(S.SIGNATURE.Public_key_hash).(S.SPublic_key_hash.size)
      in
    existT (fun _ => _) tt
      {|
        Blake2B.PrefixedName.name := name;
        Blake2B.PrefixedName.title := title;
        Blake2B.PrefixedName.size := size;
        Blake2B.PrefixedName.b58check_prefix := b58check_prefix
      |}).

Definition t := (|H|).(S.HASH.t).

Definition name := (|H|).(S.HASH.name).

Definition title := (|H|).(S.HASH.title).

Definition pp := (|H|).(S.HASH.pp).

Definition pp_short := (|H|).(S.HASH.pp_short).

Definition op_eq := (|H|).(S.HASH.op_eq).

Definition op_ltgt := (|H|).(S.HASH.op_ltgt).

Definition op_lt := (|H|).(S.HASH.op_lt).

Definition op_lteq := (|H|).(S.HASH.op_lteq).

Definition op_gteq := (|H|).(S.HASH.op_gteq).

Definition op_gt := (|H|).(S.HASH.op_gt).

Definition compare := (|H|).(S.HASH.compare).

Definition equal := (|H|).(S.HASH.equal).

Definition max := (|H|).(S.HASH.max).

Definition min := (|H|).(S.HASH.min).

Definition hash_bytes := (|H|).(S.HASH.hash_bytes).

Definition hash_string := (|H|).(S.HASH.hash_string).

Definition zero := (|H|).(S.HASH.zero).

Definition size := (|H|).(S.HASH.size).

Definition to_bytes := (|H|).(S.HASH.to_bytes).

Definition of_bytes_opt := (|H|).(S.HASH.of_bytes_opt).

Definition of_bytes_exn := (|H|).(S.HASH.of_bytes_exn).

Definition to_b58check := (|H|).(S.HASH.to_b58check).

Definition to_short_b58check := (|H|).(S.HASH.to_short_b58check).

Definition of_b58check_exn := (|H|).(S.HASH.of_b58check_exn).

Definition of_b58check_opt := (|H|).(S.HASH.of_b58check_opt).

Definition b58check_encoding := (|H|).(S.HASH.b58check_encoding).

Definition encoding := (|H|).(S.HASH.encoding).

Definition rpc_arg := (|H|).(S.HASH.rpc_arg).

Definition to_path := (|H|).(S.HASH.to_path).

Definition of_path := (|H|).(S.HASH.of_path).

Definition of_path_exn := (|H|).(S.HASH.of_path_exn).

Definition prefix_path := (|H|).(S.HASH.prefix_path).

Definition path_length := (|H|).(S.HASH.path_length).

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition of_ed25519_pkh
  (activation_code : MBytes.t)
  (pkh : (|Ed25519|).(S.SIGNATURE.Public_key_hash).(S.SPublic_key_hash.t))
  : t :=
  hash_bytes (Some activation_code)
    [
      (|Ed25519|).(S.SIGNATURE.Public_key_hash).(S.SPublic_key_hash.to_bytes)
        pkh
    ].

Definition activation_code := MBytes.t.

Definition activation_code_size : Z :=
  (|Ed25519|).(S.SIGNATURE.Public_key_hash).(S.SPublic_key_hash.size).

Definition activation_code_encoding : Data_encoding.encoding MBytes.t :=
  Data_encoding.Fixed.__bytes_value activation_code_size.

Definition activation_code_of_hex (h : string) : MBytes.t :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  MBytes.of_hex
    (* ❌ Variants not supported *)
    (* ❌ `Hex *)
    (MBytes.Hex h).

Definition Index := H.

Blinded_public_key_hash_mli

  • OCaml size: 36 lines
  • Coq size: 100 lines (+177% compared to OCaml)
blinded_public_key_hash.mli 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include S.HASH

type activation_code

val activation_code_encoding : activation_code Data_encoding.t

val of_ed25519_pkh : activation_code -> Ed25519.Public_key_hash.t -> t

val activation_code_of_hex : string -> activation_code

module Index : Storage_description.INDEX with type t = t
Blinded_public_key_hash_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Storage_description.

Parameter Included_HASH :
  {'[t, __Set_t, Map_t] : _ & S.HASH.signature t __Set_t Map_t}.

Definition t := (|Included_HASH|).(S.HASH.t).

Definition name := (|Included_HASH|).(S.HASH.name).

Definition title := (|Included_HASH|).(S.HASH.title).

Definition pp := (|Included_HASH|).(S.HASH.pp).

Definition pp_short := (|Included_HASH|).(S.HASH.pp_short).

Definition op_eq := (|Included_HASH|).(S.HASH.op_eq).

Definition op_ltgt := (|Included_HASH|).(S.HASH.op_ltgt).

Definition op_lt := (|Included_HASH|).(S.HASH.op_lt).

Definition op_lteq := (|Included_HASH|).(S.HASH.op_lteq).

Definition op_gteq := (|Included_HASH|).(S.HASH.op_gteq).

Definition op_gt := (|Included_HASH|).(S.HASH.op_gt).

Definition compare := (|Included_HASH|).(S.HASH.compare).

Definition equal := (|Included_HASH|).(S.HASH.equal).

Definition max := (|Included_HASH|).(S.HASH.max).

Definition min := (|Included_HASH|).(S.HASH.min).

Definition hash_bytes := (|Included_HASH|).(S.HASH.hash_bytes).

Definition hash_string := (|Included_HASH|).(S.HASH.hash_string).

Definition zero := (|Included_HASH|).(S.HASH.zero).

Definition size := (|Included_HASH|).(S.HASH.size).

Definition to_bytes := (|Included_HASH|).(S.HASH.to_bytes).

Definition of_bytes_opt := (|Included_HASH|).(S.HASH.of_bytes_opt).

Definition of_bytes_exn := (|Included_HASH|).(S.HASH.of_bytes_exn).

Definition to_b58check := (|Included_HASH|).(S.HASH.to_b58check).

Definition to_short_b58check := (|Included_HASH|).(S.HASH.to_short_b58check).

Definition of_b58check_exn := (|Included_HASH|).(S.HASH.of_b58check_exn).

Definition of_b58check_opt := (|Included_HASH|).(S.HASH.of_b58check_opt).

Definition b58check_encoding := (|Included_HASH|).(S.HASH.b58check_encoding).

Definition encoding := (|Included_HASH|).(S.HASH.encoding).

Definition rpc_arg := (|Included_HASH|).(S.HASH.rpc_arg).

Definition to_path := (|Included_HASH|).(S.HASH.to_path).

Definition of_path := (|Included_HASH|).(S.HASH.of_path).

Definition of_path_exn := (|Included_HASH|).(S.HASH.of_path_exn).

Definition prefix_path := (|Included_HASH|).(S.HASH.prefix_path).

Definition path_length := (|Included_HASH|).(S.HASH.path_length).

Definition __Set := existT (fun _ => _) tt (|Included_HASH|).(S.HASH.__Set).

Definition Map := existT (fun _ => _) tt (|Included_HASH|).(S.HASH.Map).

Parameter activation_code : Set.

Parameter activation_code_encoding : Data_encoding.t activation_code.

Parameter of_ed25519_pkh :
  activation_code ->
  (|Ed25519|).(S.SIGNATURE.Public_key_hash).(S.SPublic_key_hash.t) -> t.

Parameter activation_code_of_hex : string -> activation_code.

Parameter Index : {_ : unit & Storage_description.INDEX.signature t}.

Block_header_repr

  • OCaml size: 130 lines
  • Coq size: 174 lines (+33% compared to OCaml)
block_header_repr.ml success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Block header *)

type contents = {
  priority : int;
  seed_nonce_hash : Nonce_hash.t option;
  proof_of_work_nonce : MBytes.t;
}

type protocol_data = {contents : contents; signature : Signature.t}

type t = {shell : Block_header.shell_header; protocol_data : protocol_data}

type block_header = t

type raw = Block_header.t

type shell_header = Block_header.shell_header

let raw_encoding = Block_header.encoding

let shell_header_encoding = Block_header.shell_header_encoding

let contents_encoding =
  let open Data_encoding in
  def "block_header.alpha.unsigned_contents"
  @@ conv
       (fun {priority; seed_nonce_hash; proof_of_work_nonce} ->
         (priority, proof_of_work_nonce, seed_nonce_hash))
       (fun (priority, proof_of_work_nonce, seed_nonce_hash) ->
         {priority; seed_nonce_hash; proof_of_work_nonce})
       (obj3
          (req "priority" uint16)
          (req
             "proof_of_work_nonce"
             (Fixed.bytes Constants_repr.proof_of_work_nonce_size))
          (opt "seed_nonce_hash" Nonce_hash.encoding))

let protocol_data_encoding =
  let open Data_encoding in
  def "block_header.alpha.signed_contents"
  @@ conv
       (fun {contents; signature} -> (contents, signature))
       (fun (contents, signature) -> {contents; signature})
       (merge_objs
          contents_encoding
          (obj1 (req "signature" Signature.encoding)))

let raw {shell; protocol_data} =
  let protocol_data =
    Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data
  in
  {Block_header.shell; protocol_data}

let unsigned_encoding =
  let open Data_encoding in
  merge_objs Block_header.shell_header_encoding contents_encoding

let encoding =
  let open Data_encoding in
  def "block_header.alpha.full_header"
  @@ conv
       (fun {shell; protocol_data} -> (shell, protocol_data))
       (fun (shell, protocol_data) -> {shell; protocol_data})
       (merge_objs Block_header.shell_header_encoding protocol_data_encoding)

(** Constants *)

let max_header_length =
  let fake_shell =
    {
      Block_header.level = 0l;
      proto_level = 0;
      predecessor = Block_hash.zero;
      timestamp = Time.of_seconds 0L;
      validation_passes = 0;
      operations_hash = Operation_list_list_hash.zero;
      fitness = Fitness_repr.from_int64 0L;
      context = Context_hash.zero;
    }
  and fake_contents =
    {
      priority = 0;
      proof_of_work_nonce =
        MBytes.create Constants_repr.proof_of_work_nonce_size;
      seed_nonce_hash = Some Nonce_hash.zero;
    }
  in
  Data_encoding.Binary.length
    encoding
    {
      shell = fake_shell;
      protocol_data = {contents = fake_contents; signature = Signature.zero};
    }

(** Header parsing entry point  *)

let hash_raw = Block_header.hash

let hash {shell; protocol_data} =
  Block_header.hash
    {
      shell;
      protocol_data =
        Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data;
    }
Block_header_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Constants_repr.
Require Tezos.Fitness_repr.
Require Tezos.Nonce_hash.

Module contents.
  Record record := Build {
    priority : Z;
    seed_nonce_hash : option Nonce_hash.t;
    proof_of_work_nonce : MBytes.t }.
  Definition with_priority priority (r : record) :=
    Build priority r.(seed_nonce_hash) r.(proof_of_work_nonce).
  Definition with_seed_nonce_hash seed_nonce_hash (r : record) :=
    Build r.(priority) seed_nonce_hash r.(proof_of_work_nonce).
  Definition with_proof_of_work_nonce proof_of_work_nonce (r : record) :=
    Build r.(priority) r.(seed_nonce_hash) proof_of_work_nonce.
End contents.
Definition contents := contents.record.

Module protocol_data.
  Record record := Build {
    contents : contents;
    signature : Signature.t }.
  Definition with_contents contents (r : record) :=
    Build contents r.(signature).
  Definition with_signature signature (r : record) :=
    Build r.(contents) signature.
End protocol_data.
Definition protocol_data := protocol_data.record.

Module t.
  Record record := Build {
    shell : Block_header.shell_header;
    protocol_data : protocol_data }.
  Definition with_shell shell (r : record) :=
    Build shell r.(protocol_data).
  Definition with_protocol_data protocol_data (r : record) :=
    Build r.(shell) protocol_data.
End t.
Definition t := t.record.

Definition block_header := t.

Definition raw := Block_header.t.

Definition shell_header := Block_header.shell_header.

Definition raw_encoding : Data_encoding.t Block_header.t :=
  Block_header.encoding.

Definition shell_header_encoding : Data_encoding.t Block_header.shell_header :=
  Block_header.shell_header_encoding.

Definition contents_encoding : Data_encoding.encoding contents :=
  Pervasives.op_atat
    (let arg := Data_encoding.def "block_header.alpha.unsigned_contents" in
    fun eta => arg None None eta)
    (Data_encoding.conv
      (fun function_parameter =>
        let '{|
          contents.priority := priority;
            contents.seed_nonce_hash := seed_nonce_hash;
            contents.proof_of_work_nonce := proof_of_work_nonce
            |} := function_parameter in
        (priority, proof_of_work_nonce, seed_nonce_hash))
      (fun function_parameter =>
        let '(priority, proof_of_work_nonce, seed_nonce_hash) :=
          function_parameter in
        {| contents.priority := priority;
          contents.seed_nonce_hash := seed_nonce_hash;
          contents.proof_of_work_nonce := proof_of_work_nonce |}) None
      (Data_encoding.obj3
        (Data_encoding.req None None "priority" Data_encoding.uint16)
        (Data_encoding.req None None "proof_of_work_nonce"
          (Data_encoding.Fixed.__bytes_value
            Constants_repr.proof_of_work_nonce_size))
        (Data_encoding.opt None None "seed_nonce_hash" Nonce_hash.encoding))).

Definition protocol_data_encoding : Data_encoding.encoding protocol_data :=
  Pervasives.op_atat
    (let arg := Data_encoding.def "block_header.alpha.signed_contents" in
    fun eta => arg None None eta)
    (Data_encoding.conv
      (fun function_parameter =>
        let '{|
          protocol_data.contents := contents;
            protocol_data.signature := signature
            |} := function_parameter in
        (contents, signature))
      (fun function_parameter =>
        let '(contents, signature) := function_parameter in
        {| protocol_data.contents := contents;
          protocol_data.signature := signature |}) None
      (Data_encoding.merge_objs contents_encoding
        (Data_encoding.obj1
          (Data_encoding.req None None "signature" Signature.encoding)))).

Definition __raw_value (function_parameter : t) : Block_header.t :=
  let '{| t.shell := shell; t.protocol_data := protocol_data |} :=
    function_parameter in
  let protocol_data :=
    Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data in
  {| Block_header.t.shell := shell;
    Block_header.t.protocol_data := protocol_data |}.

Definition unsigned_encoding
  : Data_encoding.encoding (Block_header.shell_header * contents) :=
  Data_encoding.merge_objs Block_header.shell_header_encoding contents_encoding.

Definition encoding : Data_encoding.encoding t :=
  Pervasives.op_atat
    (let arg := Data_encoding.def "block_header.alpha.full_header" in
    fun eta => arg None None eta)
    (Data_encoding.conv
      (fun function_parameter =>
        let '{| t.shell := shell; t.protocol_data := protocol_data |} :=
          function_parameter in
        (shell, protocol_data))
      (fun function_parameter =>
        let '(shell, protocol_data) := function_parameter in
        {| t.shell := shell; t.protocol_data := protocol_data |}) None
      (Data_encoding.merge_objs Block_header.shell_header_encoding
        protocol_data_encoding)).

Definition max_header_length : Z :=
  let fake_shell : Block_header.shell_header :=
    {|
      Block_header.shell_header.level :=
        (* ❌ Constant of type int32 is converted to int *)
        0; Block_header.shell_header.proto_level := 0;
      Block_header.shell_header.predecessor := (|Block_hash|).(S.HASH.zero);
      Block_header.shell_header.timestamp :=
        Time.of_seconds
          (* ❌ Constant of type int64 is converted to int *)
          0; Block_header.shell_header.validation_passes := 0;
      Block_header.shell_header.operations_hash :=
        (|Operation_list_list_hash|).(S.MERKLE_TREE.zero);
      Block_header.shell_header.fitness :=
        Fitness_repr.from_int64
          (* ❌ Constant of type int64 is converted to int *)
          0; Block_header.shell_header.context := (|Context_hash|).(S.HASH.zero)
      |}
  with fake_contents : contents :=
    {| contents.priority := 0; contents.seed_nonce_hash := Some Nonce_hash.zero;
      contents.proof_of_work_nonce :=
        MBytes.create Constants_repr.proof_of_work_nonce_size |} in
  Data_encoding.Binary.length encoding
    {| t.shell := fake_shell;
      t.protocol_data :=
        {| protocol_data.contents := fake_contents;
          protocol_data.signature := Signature.zero |} |}.

Definition hash_raw : Block_header.t -> (|Block_hash|).(S.HASH.t) :=
  Block_header.__hash_value.

Definition __hash_value (function_parameter : t) : (|Block_hash|).(S.HASH.t) :=
  let '{| t.shell := shell; t.protocol_data := protocol_data |} :=
    function_parameter in
  Block_header.__hash_value
    {| Block_header.t.shell := shell;
      Block_header.t.protocol_data :=
        Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data
      |}.

Block_header_repr_mli

  • OCaml size: 61 lines
  • Coq size: 76 lines (+24% compared to OCaml)
block_header_repr.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type contents = {
  priority : int;
  seed_nonce_hash : Nonce_hash.t option;
  proof_of_work_nonce : MBytes.t;
}

type protocol_data = {contents : contents; signature : Signature.t}

type t = {shell : Block_header.shell_header; protocol_data : protocol_data}

type block_header = t

type raw = Block_header.t

type shell_header = Block_header.shell_header

val raw : block_header -> raw

val encoding : block_header Data_encoding.encoding

val raw_encoding : raw Data_encoding.t

val contents_encoding : contents Data_encoding.t

val unsigned_encoding : (Block_header.shell_header * contents) Data_encoding.t

val protocol_data_encoding : protocol_data Data_encoding.encoding

val shell_header_encoding : shell_header Data_encoding.encoding

(** The maximum size of block headers in bytes *)
val max_header_length : int

val hash : block_header -> Block_hash.t

val hash_raw : raw -> Block_hash.t
Block_header_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Nonce_hash.

Module contents.
  Record record := Build {
    priority : Z;
    seed_nonce_hash : option Nonce_hash.t;
    proof_of_work_nonce : MBytes.t }.
  Definition with_priority priority (r : record) :=
    Build priority r.(seed_nonce_hash) r.(proof_of_work_nonce).
  Definition with_seed_nonce_hash seed_nonce_hash (r : record) :=
    Build r.(priority) seed_nonce_hash r.(proof_of_work_nonce).
  Definition with_proof_of_work_nonce proof_of_work_nonce (r : record) :=
    Build r.(priority) r.(seed_nonce_hash) proof_of_work_nonce.
End contents.
Definition contents := contents.record.

Module protocol_data.
  Record record := Build {
    contents : contents;
    signature : Signature.t }.
  Definition with_contents contents (r : record) :=
    Build contents r.(signature).
  Definition with_signature signature (r : record) :=
    Build r.(contents) signature.
End protocol_data.
Definition protocol_data := protocol_data.record.

Module t.
  Record record := Build {
    shell : Block_header.shell_header;
    protocol_data : protocol_data }.
  Definition with_shell shell (r : record) :=
    Build shell r.(protocol_data).
  Definition with_protocol_data protocol_data (r : record) :=
    Build r.(shell) protocol_data.
End t.
Definition t := t.record.

Definition block_header := t.

Definition raw := Block_header.t.

Definition shell_header := Block_header.shell_header.

Parameter __raw_value : block_header -> raw.

Parameter encoding : Data_encoding.encoding block_header.

Parameter raw_encoding : Data_encoding.t raw.

Parameter contents_encoding : Data_encoding.t contents.

Parameter unsigned_encoding :
  Data_encoding.t (Block_header.shell_header * contents).

Parameter protocol_data_encoding : Data_encoding.encoding protocol_data.

Parameter shell_header_encoding : Data_encoding.encoding shell_header.

Parameter max_header_length : Z.

Parameter __hash_value : block_header -> (|Block_hash|).(S.HASH.t).

Parameter hash_raw : raw -> (|Block_hash|).(S.HASH.t).

Bootstrap_storage

  • OCaml size: 152 lines
  • Coq size: 216 lines (+42% compared to OCaml)
bootstrap_storage.ml success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Misc

let init_account ctxt
    ({public_key_hash; public_key; amount} : Parameters_repr.bootstrap_account)
    =
  let contract = Contract_repr.implicit_contract public_key_hash in
  Contract_storage.credit ctxt contract amount
  >>=? fun ctxt ->
  match public_key with
  | Some public_key ->
      Contract_storage.reveal_manager_key ctxt public_key_hash public_key
      >>=? fun ctxt ->
      Delegate_storage.set ctxt contract (Some public_key_hash)
      >>=? fun ctxt -> return ctxt
  | None ->
      return ctxt

let init_contract ~typecheck ctxt
    ({delegate; amount; script} : Parameters_repr.bootstrap_contract) =
  Contract_storage.fresh_contract_from_current_nonce ctxt
  >>=? fun (ctxt, contract) ->
  typecheck ctxt script
  >>=? fun (script, ctxt) ->
  Contract_storage.originate
    ctxt
    contract
    ~balance:amount
    ~prepaid_bootstrap_storage:true
    ~script
    ~delegate:(Some delegate)
  >>=? fun ctxt -> return ctxt

let init ctxt ~typecheck ?ramp_up_cycles ?no_reward_cycles accounts contracts =
  let nonce =
    Operation_hash.hash_bytes [MBytes.of_string "Un festival de GADT."]
  in
  let ctxt = Raw_context.init_origination_nonce ctxt nonce in
  fold_left_s init_account ctxt accounts
  >>=? fun ctxt ->
  fold_left_s (init_contract ~typecheck) ctxt contracts
  >>=? fun ctxt ->
  ( match no_reward_cycles with
  | None ->
      return ctxt
  | Some cycles ->
      (* Store pending ramp ups. *)
      let constants = Raw_context.constants ctxt in
      (* Start without reward *)
      Raw_context.patch_constants ctxt (fun c ->
          {
            c with
            block_reward = Tez_repr.zero;
            endorsement_reward = Tez_repr.zero;
          })
      >>= fun ctxt ->
      (* Store the final reward. *)
      Storage.Ramp_up.Rewards.init
        ctxt
        (Cycle_repr.of_int32_exn (Int32.of_int cycles))
        (constants.block_reward, constants.endorsement_reward) )
  >>=? fun ctxt ->
  match ramp_up_cycles with
  | None ->
      return ctxt
  | Some cycles ->
      (* Store pending ramp ups. *)
      let constants = Raw_context.constants ctxt in
      Lwt.return
        Tez_repr.(constants.block_security_deposit /? Int64.of_int cycles)
      >>=? fun block_step ->
      Lwt.return
        Tez_repr.(
          constants.endorsement_security_deposit /? Int64.of_int cycles)
      >>=? fun endorsement_step ->
      (* Start without security_deposit *)
      Raw_context.patch_constants ctxt (fun c ->
          {
            c with
            block_security_deposit = Tez_repr.zero;
            endorsement_security_deposit = Tez_repr.zero;
          })
      >>= fun ctxt ->
      fold_left_s
        (fun ctxt cycle ->
          Lwt.return Tez_repr.(block_step *? Int64.of_int cycle)
          >>=? fun block_security_deposit ->
          Lwt.return Tez_repr.(endorsement_step *? Int64.of_int cycle)
          >>=? fun endorsement_security_deposit ->
          let cycle = Cycle_repr.of_int32_exn (Int32.of_int cycle) in
          Storage.Ramp_up.Security_deposits.init
            ctxt
            cycle
            (block_security_deposit, endorsement_security_deposit))
        ctxt
        (1 --> (cycles - 1))
      >>=? fun ctxt ->
      (* Store the final security deposits. *)
      Storage.Ramp_up.Security_deposits.init
        ctxt
        (Cycle_repr.of_int32_exn (Int32.of_int cycles))
        ( constants.block_security_deposit,
          constants.endorsement_security_deposit )
      >>=? fun ctxt -> return ctxt

let cycle_end ctxt last_cycle =
  let next_cycle = Cycle_repr.succ last_cycle in
  Storage.Ramp_up.Rewards.get_option ctxt next_cycle
  >>=? (function
         | None ->
             return ctxt
         | Some (block_reward, endorsement_reward) ->
             Storage.Ramp_up.Rewards.delete ctxt next_cycle
             >>=? fun ctxt ->
             Raw_context.patch_constants ctxt (fun c ->
                 {c with block_reward; endorsement_reward})
             >>= fun ctxt -> return ctxt)
  >>=? fun ctxt ->
  Storage.Ramp_up.Security_deposits.get_option ctxt next_cycle
  >>=? function
  | None ->
      return ctxt
  | Some (block_security_deposit, endorsement_security_deposit) ->
      Storage.Ramp_up.Security_deposits.delete ctxt next_cycle
      >>=? fun ctxt ->
      Raw_context.patch_constants ctxt (fun c ->
          {c with block_security_deposit; endorsement_security_deposit})
      >>= fun ctxt -> return ctxt
Bootstrap_storage.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Constants_repr.
Require Tezos.Contract_repr.
Require Tezos.Contract_storage.
Require Tezos.Cycle_repr.
Require Tezos.Delegate_storage.
Require Tezos.Misc.
Require Tezos.Parameters_repr.
Require Tezos.Raw_context.
Require Tezos.Script_repr.
Require Tezos.Storage.
Require Tezos.Tez_repr.

Import Misc.

Definition init_account
  (ctxt : Raw_context.t)
  (function_parameter : Parameters_repr.bootstrap_account)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let '{|
    Parameters_repr.bootstrap_account.public_key_hash := public_key_hash;
      Parameters_repr.bootstrap_account.public_key := public_key;
      Parameters_repr.bootstrap_account.amount := amount
      |} := function_parameter in
  let contract := Contract_repr.implicit_contract public_key_hash in
  Error_monad.op_gtgteqquestion (Contract_storage.credit ctxt contract amount)
    (fun ctxt =>
      match public_key with
      | Some public_key =>
        Error_monad.op_gtgteqquestion
          (Contract_storage.reveal_manager_key ctxt public_key_hash public_key)
          (fun ctxt =>
            Error_monad.op_gtgteqquestion
              (Delegate_storage.set ctxt contract (Some public_key_hash))
              (fun ctxt => Error_monad.__return ctxt))
      | None => Error_monad.__return ctxt
      end).

Definition init_contract
  (typecheck :
    Raw_context.t -> Script_repr.t ->
    Lwt.t
      (Error_monad.tzresult
        ((Script_repr.t * option Contract_storage.big_map_diff) * Raw_context.t)))
  (ctxt : Raw_context.t)
  (function_parameter : Parameters_repr.bootstrap_contract)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let '{|
    Parameters_repr.bootstrap_contract.delegate := delegate;
      Parameters_repr.bootstrap_contract.amount := amount;
      Parameters_repr.bootstrap_contract.script := script
      |} := function_parameter in
  Error_monad.op_gtgteqquestion
    (Contract_storage.fresh_contract_from_current_nonce ctxt)
    (fun function_parameter =>
      let '(ctxt, contract) := function_parameter in
      Error_monad.op_gtgteqquestion (typecheck ctxt script)
        (fun function_parameter =>
          let '(script, ctxt) := function_parameter in
          Error_monad.op_gtgteqquestion
            (Contract_storage.originate ctxt (Some true) contract amount script
              (Some delegate)) (fun ctxt => Error_monad.__return ctxt))).

Definition init
  (ctxt : Raw_context.t)
  (typecheck :
    Raw_context.t -> Script_repr.t ->
    Lwt.t
      (Error_monad.tzresult
        ((Script_repr.t * option Contract_storage.big_map_diff) * Raw_context.t)))
  (ramp_up_cycles : option Z) (no_reward_cycles : option Z)
  (accounts : list Parameters_repr.bootstrap_account)
  (contracts : list Parameters_repr.bootstrap_contract)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let __nonce_value :=
    (|Operation_hash|).(S.HASH.hash_bytes) None
      [ MBytes.of_string "Un festival de GADT." ] in
  let ctxt := Raw_context.init_origination_nonce ctxt __nonce_value in
  Error_monad.op_gtgteqquestion
    (Error_monad.fold_left_s init_account ctxt accounts)
    (fun ctxt =>
      Error_monad.op_gtgteqquestion
        (Error_monad.fold_left_s (init_contract typecheck) ctxt contracts)
        (fun ctxt =>
          Error_monad.op_gtgteqquestion
            match no_reward_cycles with
            | None => Error_monad.__return ctxt
            | Some cycles =>
              let constants := Raw_context.constants ctxt in
              Error_monad.op_gtgteq
                (Raw_context.patch_constants ctxt
                  (fun c =>
                    Constants_repr.parametric.with_endorsement_reward
                      Tez_repr.zero
                      (Constants_repr.parametric.with_block_reward Tez_repr.zero
                        c)))
                (fun ctxt =>
                  Storage.Ramp_up.Rewards.init ctxt
                    (Cycle_repr.of_int32_exn (Int32.of_int cycles))
                    ((Constants_repr.parametric.block_reward constants),
                      (Constants_repr.parametric.endorsement_reward constants)))
            end
            (fun ctxt =>
              match ramp_up_cycles with
              | None => Error_monad.__return ctxt
              | Some cycles =>
                let constants := Raw_context.constants ctxt in
                Error_monad.op_gtgteqquestion
                  (Lwt.__return
                    (Tez_repr.op_divquestion
                      (Constants_repr.parametric.block_security_deposit
                        constants) (Int64.of_int cycles)))
                  (fun block_step =>
                    Error_monad.op_gtgteqquestion
                      (Lwt.__return
                        (Tez_repr.op_divquestion
                          (Constants_repr.parametric.endorsement_security_deposit
                            constants) (Int64.of_int cycles)))
                      (fun endorsement_step =>
                        Error_monad.op_gtgteq
                          (Raw_context.patch_constants ctxt
                            (fun c =>
                              Constants_repr.parametric.with_endorsement_security_deposit
                                Tez_repr.zero
                                (Constants_repr.parametric.with_block_security_deposit
                                  Tez_repr.zero c)))
                          (fun ctxt =>
                            Error_monad.op_gtgteqquestion
                              (Error_monad.fold_left_s
                                (fun ctxt =>
                                  fun cycle =>
                                    Error_monad.op_gtgteqquestion
                                      (Lwt.__return
                                        (Tez_repr.op_starquestion block_step
                                          (Int64.of_int cycle)))
                                      (fun block_security_deposit =>
                                        Error_monad.op_gtgteqquestion
                                          (Lwt.__return
                                            (Tez_repr.op_starquestion
                                              endorsement_step
                                              (Int64.of_int cycle)))
                                          (fun endorsement_security_deposit =>
                                            let cycle :=
                                              Cycle_repr.of_int32_exn
                                                (Int32.of_int cycle) in
                                            Storage.Ramp_up.Security_deposits.init
                                              ctxt cycle
                                              (block_security_deposit,
                                                endorsement_security_deposit))))
                                ctxt
                                (Misc.op_minusminusgt 1
                                  (Pervasives.op_minus cycles 1)))
                              (fun ctxt =>
                                Error_monad.op_gtgteqquestion
                                  (Storage.Ramp_up.Security_deposits.init ctxt
                                    (Cycle_repr.of_int32_exn
                                      (Int32.of_int cycles))
                                    ((Constants_repr.parametric.block_security_deposit
                                      constants),
                                      (Constants_repr.parametric.endorsement_security_deposit
                                        constants)))
                                  (fun ctxt => Error_monad.__return ctxt)))))
              end))).

Definition cycle_end
  (ctxt : Storage.Ramp_up.Rewards.context) (last_cycle : Cycle_repr.cycle)
  : Lwt.t (Error_monad.tzresult Storage.Ramp_up.Rewards.context) :=
  let next_cycle := Cycle_repr.succ last_cycle in
  Error_monad.op_gtgteqquestion
    (Error_monad.op_gtgteqquestion
      (Storage.Ramp_up.Rewards.get_option ctxt next_cycle)
      (fun function_parameter =>
        match function_parameter with
        | None => Error_monad.__return ctxt
        | Some (block_reward, endorsement_reward) =>
          Error_monad.op_gtgteqquestion
            (Storage.Ramp_up.Rewards.delete ctxt next_cycle)
            (fun ctxt =>
              Error_monad.op_gtgteq
                (Raw_context.patch_constants ctxt
                  (fun c =>
                    Constants_repr.parametric.with_endorsement_reward
                      endorsement_reward
                      (Constants_repr.parametric.with_block_reward block_reward
                        c))) (fun ctxt => Error_monad.__return ctxt))
        end))
    (fun ctxt =>
      Error_monad.op_gtgteqquestion
        (Storage.Ramp_up.Security_deposits.get_option ctxt next_cycle)
        (fun function_parameter =>
          match function_parameter with
          | None => Error_monad.__return ctxt
          | Some (block_security_deposit, endorsement_security_deposit) =>
            Error_monad.op_gtgteqquestion
              (Storage.Ramp_up.Security_deposits.delete ctxt next_cycle)
              (fun ctxt =>
                Error_monad.op_gtgteq
                  (Raw_context.patch_constants ctxt
                    (fun c =>
                      Constants_repr.parametric.with_endorsement_security_deposit
                        endorsement_security_deposit
                        (Constants_repr.parametric.with_block_security_deposit
                          block_security_deposit c)))
                  (fun ctxt => Error_monad.__return ctxt))
          end)).

Bootstrap_storage_mli

  • OCaml size: 40 lines
  • Coq size: 30 lines (-25% compared to OCaml)
bootstrap_storage.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val init :
  Raw_context.t ->
  typecheck:(Raw_context.t ->
            Script_repr.t ->
            ( (Script_repr.t * Contract_storage.big_map_diff option)
            * Raw_context.t )
            tzresult
            Lwt.t) ->
  ?ramp_up_cycles:int ->
  ?no_reward_cycles:int ->
  Parameters_repr.bootstrap_account list ->
  Parameters_repr.bootstrap_contract list ->
  Raw_context.t tzresult Lwt.t

val cycle_end : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t
Bootstrap_storage_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Contract_storage.
Require Tezos.Cycle_repr.
Require Tezos.Parameters_repr.
Require Tezos.Raw_context.
Require Tezos.Script_repr.

Parameter init :
  Raw_context.t ->
  (Raw_context.t -> Script_repr.t ->
  Lwt.t
    (Error_monad.tzresult
      ((Script_repr.t * option Contract_storage.big_map_diff) * Raw_context.t)))
  -> option Z -> option Z -> list Parameters_repr.bootstrap_account ->
  list Parameters_repr.bootstrap_contract ->
  Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter cycle_end :
  Raw_context.t -> Cycle_repr.t -> Lwt.t (Error_monad.tzresult Raw_context.t).

Commitment_repr

  • OCaml size: 38 lines
  • Coq size: 40 lines (+5% compared to OCaml)
commitment_repr.ml success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  blinded_public_key_hash : Blinded_public_key_hash.t;
  amount : Tez_repr.t;
}

let encoding =
  let open Data_encoding in
  conv
    (fun {blinded_public_key_hash; amount} ->
      (blinded_public_key_hash, amount))
    (fun (blinded_public_key_hash, amount) ->
      {blinded_public_key_hash; amount})
    (tup2 Blinded_public_key_hash.encoding Tez_repr.encoding)
Commitment_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Blinded_public_key_hash.
Require Tezos.Tez_repr.

Module t.
  Record record := Build {
    blinded_public_key_hash : Blinded_public_key_hash.t;
    amount : Tez_repr.t }.
  Definition with_blinded_public_key_hash blinded_public_key_hash
    (r : record) :=
    Build blinded_public_key_hash r.(amount).
  Definition with_amount amount (r : record) :=
    Build r.(blinded_public_key_hash) amount.
End t.
Definition t := t.record.

Definition encoding : Data_encoding.encoding t :=
  Data_encoding.conv
    (fun function_parameter =>
      let '{|
        t.blinded_public_key_hash := blinded_public_key_hash;
          t.amount := amount
          |} := function_parameter in
      (blinded_public_key_hash, amount))
    (fun function_parameter =>
      let '(blinded_public_key_hash, amount) := function_parameter in
      {| t.blinded_public_key_hash := blinded_public_key_hash;
        t.amount := amount |}) None
    (Data_encoding.tup2 Blinded_public_key_hash.encoding Tez_repr.encoding).

Commitment_repr_mli

  • OCaml size: 31 lines
  • Coq size: 28 lines (-10% compared to OCaml)
commitment_repr.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  blinded_public_key_hash : Blinded_public_key_hash.t;
  amount : Tez_repr.t;
}

val encoding : t Data_encoding.t
Commitment_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Blinded_public_key_hash.
Require Tezos.Tez_repr.

Module t.
  Record record := Build {
    blinded_public_key_hash : Blinded_public_key_hash.t;
    amount : Tez_repr.t }.
  Definition with_blinded_public_key_hash blinded_public_key_hash
    (r : record) :=
    Build blinded_public_key_hash r.(amount).
  Definition with_amount amount (r : record) :=
    Build r.(blinded_public_key_hash) amount.
End t.
Definition t := t.record.

Parameter encoding : Data_encoding.t t.

Commitment_storage

  • OCaml size: 34 lines
  • Coq size: 40 lines (+17% compared to OCaml)
commitment_storage.ml success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let get_opt = Storage.Commitments.get_option

let delete = Storage.Commitments.delete

let init ctxt commitments =
  let init_commitment ctxt Commitment_repr.{blinded_public_key_hash; amount} =
    Storage.Commitments.init ctxt blinded_public_key_hash amount
  in
  fold_left_s init_commitment ctxt commitments >>=? fun ctxt -> return ctxt
Commitment_storage.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Commitment_repr.
Require Tezos.Raw_context.
Require Tezos.Storage.

Definition get_opt
  : Storage.Commitments.context -> Storage.Commitments.key ->
  Lwt.t (Error_monad.tzresult (option Storage.Commitments.value)) :=
  Storage.Commitments.get_option.

Definition delete
  : Storage.Commitments.context -> Storage.Commitments.key ->
  Lwt.t (Error_monad.tzresult Raw_context.t) := Storage.Commitments.delete.

Definition init
  (ctxt : Storage.Commitments.context) (commitments : list Commitment_repr.t)
  : Lwt.t (Error_monad.tzresult Storage.Commitments.context) :=
  let init_commitment
    (ctxt : Storage.Commitments.context)
    (function_parameter : Commitment_repr.t)
    : Lwt.t (Error_monad.tzresult Raw_context.t) :=
    let '{|
      Commitment_repr.t.blinded_public_key_hash := blinded_public_key_hash;
        Commitment_repr.t.amount := amount
        |} := function_parameter in
    Storage.Commitments.init ctxt blinded_public_key_hash amount in
  Error_monad.op_gtgteqquestion
    (Error_monad.fold_left_s init_commitment ctxt commitments)
    (fun ctxt => Error_monad.__return ctxt).

Commitment_storage_mli

  • OCaml size: 35 lines
  • Coq size: 28 lines (-20% compared to OCaml)
commitment_storage.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val init :
  Raw_context.t -> Commitment_repr.t list -> Raw_context.t tzresult Lwt.t

val get_opt :
  Raw_context.t ->
  Blinded_public_key_hash.t ->
  Tez_repr.t option tzresult Lwt.t

val delete :
  Raw_context.t -> Blinded_public_key_hash.t -> Raw_context.t tzresult Lwt.t
Commitment_storage_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Blinded_public_key_hash.
Require Tezos.Commitment_repr.
Require Tezos.Raw_context.
Require Tezos.Tez_repr.

Parameter init :
  Raw_context.t -> list Commitment_repr.t ->
  Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter get_opt :
  Raw_context.t -> Blinded_public_key_hash.t ->
  Lwt.t (Error_monad.tzresult (option Tez_repr.t)).

Parameter delete :
  Raw_context.t -> Blinded_public_key_hash.t ->
  Lwt.t (Error_monad.tzresult Raw_context.t).

Constants_repr

  • OCaml size: 238 lines
  • Coq size: 605 lines (+154% compared to OCaml)
constants_repr.ml success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let version_number_004 = "\000"

let version_number = "\001"

let proof_of_work_nonce_size = 8

let nonce_length = 32

let max_revelations_per_block = 32

let max_proposals_per_delegate = 20

let max_operation_data_length = 16 * 1024 (* 16kB *)

type fixed = {
  proof_of_work_nonce_size : int;
  nonce_length : int;
  max_revelations_per_block : int;
  max_operation_data_length : int;
  max_proposals_per_delegate : int;
}

let fixed_encoding =
  let open Data_encoding in
  conv
    (fun c ->
      ( c.proof_of_work_nonce_size,
        c.nonce_length,
        c.max_revelations_per_block,
        c.max_operation_data_length,
        c.max_proposals_per_delegate ))
    (fun ( proof_of_work_nonce_size,
           nonce_length,
           max_revelations_per_block,
           max_operation_data_length,
           max_proposals_per_delegate ) ->
      {
        proof_of_work_nonce_size;
        nonce_length;
        max_revelations_per_block;
        max_operation_data_length;
        max_proposals_per_delegate;
      })
    (obj5
       (req "proof_of_work_nonce_size" uint8)
       (req "nonce_length" uint8)
       (req "max_revelations_per_block" uint8)
       (req "max_operation_data_length" int31)
       (req "max_proposals_per_delegate" uint8))

let fixed =
  {
    proof_of_work_nonce_size;
    nonce_length;
    max_revelations_per_block;
    max_operation_data_length;
    max_proposals_per_delegate;
  }

type parametric = {
  preserved_cycles : int;
  blocks_per_cycle : int32;
  blocks_per_commitment : int32;
  blocks_per_roll_snapshot : int32;
  blocks_per_voting_period : int32;
  time_between_blocks : Period_repr.t list;
  endorsers_per_block : int;
  hard_gas_limit_per_operation : Z.t;
  hard_gas_limit_per_block : Z.t;
  proof_of_work_threshold : int64;
  tokens_per_roll : Tez_repr.t;
  michelson_maximum_type_size : int;
  seed_nonce_revelation_tip : Tez_repr.t;
  origination_size : int;
  block_security_deposit : Tez_repr.t;
  endorsement_security_deposit : Tez_repr.t;
  block_reward : Tez_repr.t;
  endorsement_reward : Tez_repr.t;
  cost_per_byte : Tez_repr.t;
  hard_storage_limit_per_operation : Z.t;
  test_chain_duration : int64;
  (* in seconds *)
  quorum_min : int32;
  quorum_max : int32;
  min_proposal_quorum : int32;
  initial_endorsers : int;
  delay_per_missing_endorsement : Period_repr.t;
}

let parametric_encoding =
  let open Data_encoding in
  conv
    (fun c ->
      ( ( c.preserved_cycles,
          c.blocks_per_cycle,
          c.blocks_per_commitment,
          c.blocks_per_roll_snapshot,
          c.blocks_per_voting_period,
          c.time_between_blocks,
          c.endorsers_per_block,
          c.hard_gas_limit_per_operation,
          c.hard_gas_limit_per_block ),
        ( ( c.proof_of_work_threshold,
            c.tokens_per_roll,
            c.michelson_maximum_type_size,
            c.seed_nonce_revelation_tip,
            c.origination_size,
            c.block_security_deposit,
            c.endorsement_security_deposit,
            c.block_reward ),
          ( c.endorsement_reward,
            c.cost_per_byte,
            c.hard_storage_limit_per_operation,
            c.test_chain_duration,
            c.quorum_min,
            c.quorum_max,
            c.min_proposal_quorum,
            c.initial_endorsers,
            c.delay_per_missing_endorsement ) ) ))
    (fun ( ( preserved_cycles,
             blocks_per_cycle,
             blocks_per_commitment,
             blocks_per_roll_snapshot,
             blocks_per_voting_period,
             time_between_blocks,
             endorsers_per_block,
             hard_gas_limit_per_operation,
             hard_gas_limit_per_block ),
           ( ( proof_of_work_threshold,
               tokens_per_roll,
               michelson_maximum_type_size,
               seed_nonce_revelation_tip,
               origination_size,
               block_security_deposit,
               endorsement_security_deposit,
               block_reward ),
             ( endorsement_reward,
               cost_per_byte,
               hard_storage_limit_per_operation,
               test_chain_duration,
               quorum_min,
               quorum_max,
               min_proposal_quorum,
               initial_endorsers,
               delay_per_missing_endorsement ) ) ) ->
      {
        preserved_cycles;
        blocks_per_cycle;
        blocks_per_commitment;
        blocks_per_roll_snapshot;
        blocks_per_voting_period;
        time_between_blocks;
        endorsers_per_block;
        hard_gas_limit_per_operation;
        hard_gas_limit_per_block;
        proof_of_work_threshold;
        tokens_per_roll;
        michelson_maximum_type_size;
        seed_nonce_revelation_tip;
        origination_size;
        block_security_deposit;
        endorsement_security_deposit;
        block_reward;
        endorsement_reward;
        cost_per_byte;
        hard_storage_limit_per_operation;
        test_chain_duration;
        quorum_min;
        quorum_max;
        min_proposal_quorum;
        initial_endorsers;
        delay_per_missing_endorsement;
      })
    (merge_objs
       (obj9
          (req "preserved_cycles" uint8)
          (req "blocks_per_cycle" int32)
          (req "blocks_per_commitment" int32)
          (req "blocks_per_roll_snapshot" int32)
          (req "blocks_per_voting_period" int32)
          (req "time_between_blocks" (list Period_repr.encoding))
          (req "endorsers_per_block" uint16)
          (req "hard_gas_limit_per_operation" z)
          (req "hard_gas_limit_per_block" z))
       (merge_objs
          (obj8
             (req "proof_of_work_threshold" int64)
             (req "tokens_per_roll" Tez_repr.encoding)
             (req "michelson_maximum_type_size" uint16)
             (req "seed_nonce_revelation_tip" Tez_repr.encoding)
             (req "origination_size" int31)
             (req "block_security_deposit" Tez_repr.encoding)
             (req "endorsement_security_deposit" Tez_repr.encoding)
             (req "block_reward" Tez_repr.encoding))
          (obj9
             (req "endorsement_reward" Tez_repr.encoding)
             (req "cost_per_byte" Tez_repr.encoding)
             (req "hard_storage_limit_per_operation" z)
             (req "test_chain_duration" int64)
             (req "quorum_min" int32)
             (req "quorum_max" int32)
             (req "min_proposal_quorum" int32)
             (req "initial_endorsers" uint16)
             (req "delay_per_missing_endorsement" Period_repr.encoding))))

type t = {fixed : fixed; parametric : parametric}

let encoding =
  let open Data_encoding in
  conv
    (fun {fixed; parametric} -> (fixed, parametric))
    (fun (fixed, parametric) -> {fixed; parametric})
    (merge_objs fixed_encoding parametric_encoding)
Constants_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Period_repr.
Require Tezos.Tez_repr.

Definition version_number_004 : string := "\000".

Definition version_number : string := "\001".

Definition proof_of_work_nonce_size : Z := 8.

Definition nonce_length : Z := 32.

Definition max_revelations_per_block : Z := 32.

Definition max_proposals_per_delegate : Z := 20.

Definition max_operation_data_length : Z := Pervasives.op_star 16 1024.

Module fixed.
  Record record := Build {
    proof_of_work_nonce_size : Z;
    nonce_length : Z;
    max_revelations_per_block : Z;
    max_operation_data_length : Z;
    max_proposals_per_delegate : Z }.
  Definition with_proof_of_work_nonce_size proof_of_work_nonce_size
    (r : record) :=
    Build proof_of_work_nonce_size r.(nonce_length)
      r.(max_revelations_per_block) r.(max_operation_data_length)
      r.(max_proposals_per_delegate).
  Definition with_nonce_length nonce_length (r : record) :=
    Build r.(proof_of_work_nonce_size) nonce_length
      r.(max_revelations_per_block) r.(max_operation_data_length)
      r.(max_proposals_per_delegate).
  Definition with_max_revelations_per_block max_revelations_per_block
    (r : record) :=
    Build r.(proof_of_work_nonce_size) r.(nonce_length)
      max_revelations_per_block r.(max_operation_data_length)
      r.(max_proposals_per_delegate).
  Definition with_max_operation_data_length max_operation_data_length
    (r : record) :=
    Build r.(proof_of_work_nonce_size) r.(nonce_length)
      r.(max_revelations_per_block) max_operation_data_length
      r.(max_proposals_per_delegate).
  Definition with_max_proposals_per_delegate max_proposals_per_delegate
    (r : record) :=
    Build r.(proof_of_work_nonce_size) r.(nonce_length)
      r.(max_revelations_per_block) r.(max_operation_data_length)
      max_proposals_per_delegate.
End fixed.
Definition fixed := fixed.record.

Definition fixed_encoding : Data_encoding.encoding fixed :=
  Data_encoding.conv
    (fun c =>
      ((fixed.proof_of_work_nonce_size c), (fixed.nonce_length c),
        (fixed.max_revelations_per_block c),
        (fixed.max_operation_data_length c),
        (fixed.max_proposals_per_delegate c)))
    (fun function_parameter =>
      let
        '(proof_of_work_nonce_size, nonce_length, max_revelations_per_block,
          max_operation_data_length, max_proposals_per_delegate) :=
        function_parameter in
      {| fixed.proof_of_work_nonce_size := proof_of_work_nonce_size;
        fixed.nonce_length := nonce_length;
        fixed.max_revelations_per_block := max_revelations_per_block;
        fixed.max_operation_data_length := max_operation_data_length;
        fixed.max_proposals_per_delegate := max_proposals_per_delegate |}) None
    (Data_encoding.obj5
      (Data_encoding.req None None "proof_of_work_nonce_size"
        Data_encoding.uint8)
      (Data_encoding.req None None "nonce_length" Data_encoding.uint8)
      (Data_encoding.req None None "max_revelations_per_block"
        Data_encoding.uint8)
      (Data_encoding.req None None "max_operation_data_length"
        Data_encoding.int31)
      (Data_encoding.req None None "max_proposals_per_delegate"
        Data_encoding.uint8)).

Definition __fixed_value : fixed :=
  {| fixed.proof_of_work_nonce_size := proof_of_work_nonce_size;
    fixed.nonce_length := nonce_length;
    fixed.max_revelations_per_block := max_revelations_per_block;
    fixed.max_operation_data_length := max_operation_data_length;
    fixed.max_proposals_per_delegate := max_proposals_per_delegate |}.

Module parametric.
  Record record := Build {
    preserved_cycles : Z;
    blocks_per_cycle : int32;
    blocks_per_commitment : int32;
    blocks_per_roll_snapshot : int32;
    blocks_per_voting_period : int32;
    time_between_blocks : list Period_repr.t;
    endorsers_per_block : Z;
    hard_gas_limit_per_operation : Z.t;
    hard_gas_limit_per_block : Z.t;
    proof_of_work_threshold : int64;
    tokens_per_roll : Tez_repr.t;
    michelson_maximum_type_size : Z;
    seed_nonce_revelation_tip : Tez_repr.t;
    origination_size : Z;
    block_security_deposit : Tez_repr.t;
    endorsement_security_deposit : Tez_repr.t;
    block_reward : Tez_repr.t;
    endorsement_reward : Tez_repr.t;
    cost_per_byte : Tez_repr.t;
    hard_storage_limit_per_operation : Z.t;
    test_chain_duration : int64;
    quorum_min : int32;
    quorum_max : int32;
    min_proposal_quorum : int32;
    initial_endorsers : Z;
    delay_per_missing_endorsement : Period_repr.t }.
  Definition with_preserved_cycles preserved_cycles (r : record) :=
    Build preserved_cycles r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_blocks_per_cycle blocks_per_cycle (r : record) :=
    Build r.(preserved_cycles) blocks_per_cycle r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_blocks_per_commitment blocks_per_commitment (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) blocks_per_commitment
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_blocks_per_roll_snapshot blocks_per_roll_snapshot
    (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      blocks_per_roll_snapshot r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_blocks_per_voting_period blocks_per_voting_period
    (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) blocks_per_voting_period
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_time_between_blocks time_between_blocks (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      time_between_blocks r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_endorsers_per_block endorsers_per_block (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) endorsers_per_block
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_hard_gas_limit_per_operation hard_gas_limit_per_operation
    (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      hard_gas_limit_per_operation r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_hard_gas_limit_per_block hard_gas_limit_per_block
    (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) hard_gas_limit_per_block
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_proof_of_work_threshold proof_of_work_threshold
    (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      proof_of_work_threshold r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_tokens_per_roll tokens_per_roll (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) tokens_per_roll
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_michelson_maximum_type_size michelson_maximum_type_size
    (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      michelson_maximum_type_size r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_seed_nonce_revelation_tip seed_nonce_revelation_tip
    (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) seed_nonce_revelation_tip
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_origination_size origination_size (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      origination_size r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_block_security_deposit block_security_deposit (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) block_security_deposit
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_endorsement_security_deposit endorsement_security_deposit
    (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      endorsement_security_deposit r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_block_reward block_reward (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) block_reward r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_endorsement_reward endorsement_reward (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) endorsement_reward
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      r.(delay_per_missing_endorsement).
  Definition with_cost_per_byte cost_per_byte (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      cost_per_byte r.(hard_storage_limit_per_operation) r.(test_chain_duration)
      r.(quorum_min) r.(quorum_max) r.(min_proposal_quorum)
      r.(initial_endorsers) r.(delay_per_missing_endorsement).
  Definition with_hard_storage_limit_per_operation
    hard_storage_limit_per_operation (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) hard_storage_limit_per_operation r.(test_chain_duration)
      r.(quorum_min) r.(quorum_max) r.(min_proposal_quorum)
      r.(initial_endorsers) r.(delay_per_missing_endorsement).
  Definition with_test_chain_duration test_chain_duration (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation) test_chain_duration
      r.(quorum_min) r.(quorum_max) r.(min_proposal_quorum)
      r.(initial_endorsers) r.(delay_per_missing_endorsement).
  Definition with_quorum_min quorum_min (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) quorum_min r.(quorum_max) r.(min_proposal_quorum)
      r.(initial_endorsers) r.(delay_per_missing_endorsement).
  Definition with_quorum_max quorum_max (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) quorum_max r.(min_proposal_quorum)
      r.(initial_endorsers) r.(delay_per_missing_endorsement).
  Definition with_min_proposal_quorum min_proposal_quorum (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max) min_proposal_quorum
      r.(initial_endorsers) r.(delay_per_missing_endorsement).
  Definition with_initial_endorsers initial_endorsers (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) initial_endorsers
      r.(delay_per_missing_endorsement).
  Definition with_delay_per_missing_endorsement delay_per_missing_endorsement
    (r : record) :=
    Build r.(preserved_cycles) r.(blocks_per_cycle) r.(blocks_per_commitment)
      r.(blocks_per_roll_snapshot) r.(blocks_per_voting_period)
      r.(time_between_blocks) r.(endorsers_per_block)
      r.(hard_gas_limit_per_operation) r.(hard_gas_limit_per_block)
      r.(proof_of_work_threshold) r.(tokens_per_roll)
      r.(michelson_maximum_type_size) r.(seed_nonce_revelation_tip)
      r.(origination_size) r.(block_security_deposit)
      r.(endorsement_security_deposit) r.(block_reward) r.(endorsement_reward)
      r.(cost_per_byte) r.(hard_storage_limit_per_operation)
      r.(test_chain_duration) r.(quorum_min) r.(quorum_max)
      r.(min_proposal_quorum) r.(initial_endorsers)
      delay_per_missing_endorsement.
End parametric.
Definition parametric := parametric.record.

Definition parametric_encoding : Data_encoding.encoding parametric :=
  Data_encoding.conv
    (fun c =>
      (((parametric.preserved_cycles c), (parametric.blocks_per_cycle c),
        (parametric.blocks_per_commitment c),
        (parametric.blocks_per_roll_snapshot c),
        (parametric.blocks_per_voting_period c),
        (parametric.time_between_blocks c), (parametric.endorsers_per_block c),
        (parametric.hard_gas_limit_per_operation c),
        (parametric.hard_gas_limit_per_block c)),
        (((parametric.proof_of_work_threshold c),
          (parametric.tokens_per_roll c),
          (parametric.michelson_maximum_type_size c),
          (parametric.seed_nonce_revelation_tip c),
          (parametric.origination_size c),
          (parametric.block_security_deposit c),
          (parametric.endorsement_security_deposit c),
          (parametric.block_reward c)),
          ((parametric.endorsement_reward c), (parametric.cost_per_byte c),
            (parametric.hard_storage_limit_per_operation c),
            (parametric.test_chain_duration c), (parametric.quorum_min c),
            (parametric.quorum_max c), (parametric.min_proposal_quorum c),
            (parametric.initial_endorsers c),
            (parametric.delay_per_missing_endorsement c)))))
    (fun function_parameter =>
      let
        '((preserved_cycles, blocks_per_cycle, blocks_per_commitment,
          blocks_per_roll_snapshot, blocks_per_voting_period,
          time_between_blocks, endorsers_per_block,
          hard_gas_limit_per_operation, hard_gas_limit_per_block),
          ((proof_of_work_threshold, tokens_per_roll,
            michelson_maximum_type_size, seed_nonce_revelation_tip,
            origination_size, block_security_deposit,
            endorsement_security_deposit, block_reward),
            (endorsement_reward, cost_per_byte,
              hard_storage_limit_per_operation, test_chain_duration, quorum_min,
              quorum_max, min_proposal_quorum, initial_endorsers,
              delay_per_missing_endorsement))) := function_parameter in
      {| parametric.preserved_cycles := preserved_cycles;
        parametric.blocks_per_cycle := blocks_per_cycle;
        parametric.blocks_per_commitment := blocks_per_commitment;
        parametric.blocks_per_roll_snapshot := blocks_per_roll_snapshot;
        parametric.blocks_per_voting_period := blocks_per_voting_period;
        parametric.time_between_blocks := time_between_blocks;
        parametric.endorsers_per_block := endorsers_per_block;
        parametric.hard_gas_limit_per_operation := hard_gas_limit_per_operation;
        parametric.hard_gas_limit_per_block := hard_gas_limit_per_block;
        parametric.proof_of_work_threshold := proof_of_work_threshold;
        parametric.tokens_per_roll := tokens_per_roll;
        parametric.michelson_maximum_type_size := michelson_maximum_type_size;
        parametric.seed_nonce_revelation_tip := seed_nonce_revelation_tip;
        parametric.origination_size := origination_size;
        parametric.block_security_deposit := block_security_deposit;
        parametric.endorsement_security_deposit := endorsement_security_deposit;
        parametric.block_reward := block_reward;
        parametric.endorsement_reward := endorsement_reward;
        parametric.cost_per_byte := cost_per_byte;
        parametric.hard_storage_limit_per_operation :=
          hard_storage_limit_per_operation;
        parametric.test_chain_duration := test_chain_duration;
        parametric.quorum_min := quorum_min;
        parametric.quorum_max := quorum_max;
        parametric.min_proposal_quorum := min_proposal_quorum;
        parametric.initial_endorsers := initial_endorsers;
        parametric.delay_per_missing_endorsement :=
          delay_per_missing_endorsement |}) None
    (Data_encoding.merge_objs
      (Data_encoding.obj9
        (Data_encoding.req None None "preserved_cycles" Data_encoding.uint8)
        (Data_encoding.req None None "blocks_per_cycle"
          Data_encoding.__int32_value)
        (Data_encoding.req None None "blocks_per_commitment"
          Data_encoding.__int32_value)
        (Data_encoding.req None None "blocks_per_roll_snapshot"
          Data_encoding.__int32_value)
        (Data_encoding.req None None "blocks_per_voting_period"
          Data_encoding.__int32_value)
        (Data_encoding.req None None "time_between_blocks"
          (Data_encoding.__list_value None Period_repr.encoding))
        (Data_encoding.req None None "endorsers_per_block" Data_encoding.uint16)
        (Data_encoding.req None None "hard_gas_limit_per_operation"
          Data_encoding.z)
        (Data_encoding.req None None "hard_gas_limit_per_block" Data_encoding.z))
      (Data_encoding.merge_objs
        (Data_encoding.obj8
          (Data_encoding.req None None "proof_of_work_threshold"
            Data_encoding.__int64_value)
          (Data_encoding.req None None "tokens_per_roll" Tez_repr.encoding)
          (Data_encoding.req None None "michelson_maximum_type_size"
            Data_encoding.uint16)
          (Data_encoding.req None None "seed_nonce_revelation_tip"
            Tez_repr.encoding)
          (Data_encoding.req None None "origination_size" Data_encoding.int31)
          (Data_encoding.req None None "block_security_deposit"
            Tez_repr.encoding)
          (Data_encoding.req None None "endorsement_security_deposit"
            Tez_repr.encoding)
          (Data_encoding.req None None "block_reward" Tez_repr.encoding))
        (Data_encoding.obj9
          (Data_encoding.req None None "endorsement_reward" Tez_repr.encoding)
          (Data_encoding.req None None "cost_per_byte" Tez_repr.encoding)
          (Data_encoding.req None None "hard_storage_limit_per_operation"
            Data_encoding.z)
          (Data_encoding.req None None "test_chain_duration"
            Data_encoding.__int64_value)
          (Data_encoding.req None None "quorum_min" Data_encoding.__int32_value)
          (Data_encoding.req None None "quorum_max" Data_encoding.__int32_value)
          (Data_encoding.req None None "min_proposal_quorum"
            Data_encoding.__int32_value)
          (Data_encoding.req None None "initial_endorsers" Data_encoding.uint16)
          (Data_encoding.req None None "delay_per_missing_endorsement"
            Period_repr.encoding)))).

Module t.
  Record record := Build {
    fixed : fixed;
    parametric : parametric }.
  Definition with_fixed fixed (r : record) :=
    Build fixed r.(parametric).
  Definition with_parametric parametric (r : record) :=
    Build r.(fixed) parametric.
End t.
Definition t := t.record.

Definition encoding : Data_encoding.encoding t :=
  Data_encoding.conv
    (fun function_parameter =>
      let '{| t.fixed := __fixed_value; t.parametric := parametric |} :=
        function_parameter in
      (__fixed_value, parametric))
    (fun function_parameter =>
      let '(__fixed_value, parametric) := function_parameter in
      {| t.fixed := __fixed_value; t.parametric := parametric |}) None
    (Data_encoding.merge_objs fixed_encoding parametric_encoding).

Constants_services

  • OCaml size: 60 lines
  • Coq size: 104 lines (+73% compared to OCaml)
constants_services.ml 29 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

let custom_root =
  ( RPC_path.(open_root / "context" / "constants")
    : RPC_context.t RPC_path.context )

module S = struct
  open Data_encoding

  let errors =
    RPC_service.get_service
      ~description:"Schema for all the RPC errors from this protocol version"
      ~query:RPC_query.empty
      ~output:json_schema
      RPC_path.(custom_root / "errors")

  let all =
    RPC_service.get_service
      ~description:"All constants"
      ~query:RPC_query.empty
      ~output:Alpha_context.Constants.encoding
      custom_root
end

let register () =
  let open Services_registration in
  register0_noctxt S.errors (fun () () ->
      return Data_encoding.Json.(schema error_encoding)) ;
  register0 S.all (fun ctxt () () ->
      let open Constants in
      return {fixed; parametric = parametric ctxt})

let errors ctxt block = RPC_context.make_call0 S.errors ctxt block () ()

let all ctxt block = RPC_context.make_call0 S.all ctxt block () ()
Constants_services.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Services_registration.

Import Alpha_context.

Definition custom_root : RPC_path.context RPC_context.t :=
  RPC_path.op_div (RPC_path.op_div RPC_path.open_root "context") "constants".

Module S.
  Import Data_encoding.
  
  Definition errors
    : RPC_service.service (* `GET *) unit RPC_context.t RPC_context.t unit unit
      Data_encoding.json_schema :=
    RPC_service.get_service
      (Some "Schema for all the RPC errors from this protocol version")
      RPC_query.empty Data_encoding.__json_schema_value
      (RPC_path.op_div custom_root "errors").
  
  Definition all
    : RPC_service.service (* `GET *) unit RPC_context.t RPC_context.t unit unit
      Alpha_context.Constants.t :=
    RPC_service.get_service (Some "All constants") RPC_query.empty
      Alpha_context.Constants.encoding custom_root.
End S.

Definition register (function_parameter : unit) : unit :=
  let '_ := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  Services_registration.register0 S.all
    (fun ctxt =>
      fun function_parameter =>
        let '_ := function_parameter in
        fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.__return
            {|
              Alpha_context.Constants.t.fixed :=
                Alpha_context.Constants.__fixed_value;
              Alpha_context.Constants.t.parametric :=
                Alpha_context.Constants.parametric ctxt |}).

Definition errors {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  : Lwt.t (Error_monad.shell_tzresult Data_encoding.json_schema) :=
  RPC_context.make_call0 S.errors ctxt block tt tt.

Definition all {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  : Lwt.t (Error_monad.shell_tzresult Alpha_context.Constants.t) :=
  RPC_context.make_call0 S.all ctxt block tt tt.

Constants_services_mli

  • OCaml size: 36 lines
  • Coq size: 59 lines (+63% compared to OCaml)
constants_services.mli 26 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

val errors :
  'a #RPC_context.simple ->
  'a ->
  Data_encoding.json_schema shell_tzresult Lwt.t

(** Returns all the constants of the protocol *)
val all : 'a #RPC_context.simple -> 'a -> Constants.t shell_tzresult Lwt.t

val register : unit -> unit
Constants_services_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.

Parameter errors : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Lwt.t (Error_monad.shell_tzresult Data_encoding.json_schema).

Parameter all : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Lwt.t (Error_monad.shell_tzresult Alpha_context.Constants.t).

Parameter register : unit -> unit.

Constants_storage

  • OCaml size: 130 lines
  • Coq size: 125 lines (-4% compared to OCaml)
constants_storage.ml success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let preserved_cycles c =
  let constants = Raw_context.constants c in
  constants.preserved_cycles

let blocks_per_cycle c =
  let constants = Raw_context.constants c in
  constants.blocks_per_cycle

let blocks_per_commitment c =
  let constants = Raw_context.constants c in
  constants.blocks_per_commitment

let blocks_per_roll_snapshot c =
  let constants = Raw_context.constants c in
  constants.blocks_per_roll_snapshot

let blocks_per_voting_period c =
  let constants = Raw_context.constants c in
  constants.blocks_per_voting_period

let time_between_blocks c =
  let constants = Raw_context.constants c in
  constants.time_between_blocks

let endorsers_per_block c =
  let constants = Raw_context.constants c in
  constants.endorsers_per_block

let initial_endorsers c =
  let constants = Raw_context.constants c in
  constants.initial_endorsers

let delay_per_missing_endorsement c =
  let constants = Raw_context.constants c in
  constants.delay_per_missing_endorsement

let hard_gas_limit_per_operation c =
  let constants = Raw_context.constants c in
  constants.hard_gas_limit_per_operation

let hard_gas_limit_per_block c =
  let constants = Raw_context.constants c in
  constants.hard_gas_limit_per_block

let cost_per_byte c =
  let constants = Raw_context.constants c in
  constants.cost_per_byte

let hard_storage_limit_per_operation c =
  let constants = Raw_context.constants c in
  constants.hard_storage_limit_per_operation

let proof_of_work_threshold c =
  let constants = Raw_context.constants c in
  constants.proof_of_work_threshold

let tokens_per_roll c =
  let constants = Raw_context.constants c in
  constants.tokens_per_roll

let michelson_maximum_type_size c =
  let constants = Raw_context.constants c in
  constants.michelson_maximum_type_size

let seed_nonce_revelation_tip c =
  let constants = Raw_context.constants c in
  constants.seed_nonce_revelation_tip

let origination_size c =
  let constants = Raw_context.constants c in
  constants.origination_size

let block_security_deposit c =
  let constants = Raw_context.constants c in
  constants.block_security_deposit

let endorsement_security_deposit c =
  let constants = Raw_context.constants c in
  constants.endorsement_security_deposit

let block_reward c =
  let constants = Raw_context.constants c in
  constants.block_reward

let endorsement_reward c =
  let constants = Raw_context.constants c in
  constants.endorsement_reward

let test_chain_duration c =
  let constants = Raw_context.constants c in
  constants.test_chain_duration

let quorum_min c =
  let constants = Raw_context.constants c in
  constants.quorum_min

let quorum_max c =
  let constants = Raw_context.constants c in
  constants.quorum_max

let min_proposal_quorum c =
  let constants = Raw_context.constants c in
  constants.min_proposal_quorum

let parametric c = Raw_context.constants c
Constants_storage.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Constants_repr.
Require Tezos.Period_repr.
Require Tezos.Raw_context.
Require Tezos.Tez_repr.

Definition preserved_cycles (c : Raw_context.context) : Z :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.preserved_cycles constants.

Definition blocks_per_cycle (c : Raw_context.context) : int32 :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.blocks_per_cycle constants.

Definition blocks_per_commitment (c : Raw_context.context) : int32 :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.blocks_per_commitment constants.

Definition blocks_per_roll_snapshot (c : Raw_context.context) : int32 :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.blocks_per_roll_snapshot constants.

Definition blocks_per_voting_period (c : Raw_context.context) : int32 :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.blocks_per_voting_period constants.

Definition time_between_blocks (c : Raw_context.context) : list Period_repr.t :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.time_between_blocks constants.

Definition endorsers_per_block (c : Raw_context.context) : Z :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.endorsers_per_block constants.

Definition initial_endorsers (c : Raw_context.context) : Z :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.initial_endorsers constants.

Definition delay_per_missing_endorsement (c : Raw_context.context)
  : Period_repr.t :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.delay_per_missing_endorsement constants.

Definition hard_gas_limit_per_operation (c : Raw_context.context) : Z.t :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.hard_gas_limit_per_operation constants.

Definition hard_gas_limit_per_block (c : Raw_context.context) : Z.t :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.hard_gas_limit_per_block constants.

Definition cost_per_byte (c : Raw_context.context) : Tez_repr.t :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.cost_per_byte constants.

Definition hard_storage_limit_per_operation (c : Raw_context.context) : Z.t :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.hard_storage_limit_per_operation constants.

Definition proof_of_work_threshold (c : Raw_context.context) : int64 :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.proof_of_work_threshold constants.

Definition tokens_per_roll (c : Raw_context.context) : Tez_repr.t :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.tokens_per_roll constants.

Definition michelson_maximum_type_size (c : Raw_context.context) : Z :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.michelson_maximum_type_size constants.

Definition seed_nonce_revelation_tip (c : Raw_context.context) : Tez_repr.t :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.seed_nonce_revelation_tip constants.

Definition origination_size (c : Raw_context.context) : Z :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.origination_size constants.

Definition block_security_deposit (c : Raw_context.context) : Tez_repr.t :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.block_security_deposit constants.

Definition endorsement_security_deposit (c : Raw_context.context)
  : Tez_repr.t :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.endorsement_security_deposit constants.

Definition block_reward (c : Raw_context.context) : Tez_repr.t :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.block_reward constants.

Definition endorsement_reward (c : Raw_context.context) : Tez_repr.t :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.endorsement_reward constants.

Definition test_chain_duration (c : Raw_context.context) : int64 :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.test_chain_duration constants.

Definition quorum_min (c : Raw_context.context) : int32 :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.quorum_min constants.

Definition quorum_max (c : Raw_context.context) : int32 :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.quorum_max constants.

Definition min_proposal_quorum (c : Raw_context.context) : int32 :=
  let constants := Raw_context.constants c in
  Constants_repr.parametric.min_proposal_quorum constants.

Definition parametric (c : Raw_context.context) : Constants_repr.parametric :=
  Raw_context.constants c.

Contract_hash

  • OCaml size: 44 lines
  • Coq size: 103 lines (+134% compared to OCaml)
contract_hash.ml 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* 20 *)
let contract_hash = "\002\090\121" (* KT1(36) *)

module Blake2BModule =
  Blake2B.Make
    (Base58)
    (struct
      let name = "Contract_hash"

      let title = "A contract ID"

      let b58check_prefix = contract_hash

      let size = Some 20
    end)

include Blake2BModule

let () = Base58.check_encoded_prefix b58check_encoding "KT1" 36
Contract_hash.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Definition contract_hash : string := "\002Zy".

Definition Blake2BModule :=
  (Blake2B.Make
    (existT (fun _ => _) tt
      {|
        Blake2B.SRegister.register_encoding {_} := Base58.register_encoding
      |}))
    (let name := "Contract_hash" in
    let title := "A contract ID" in
    let b58check_prefix := contract_hash in
    let size := Some 20 in
    existT (fun _ => _) tt
      {|
        Blake2B.PrefixedName.name := name;
        Blake2B.PrefixedName.title := title;
        Blake2B.PrefixedName.size := size;
        Blake2B.PrefixedName.b58check_prefix := b58check_prefix
      |}).

Definition t := (|Blake2BModule|).(S.HASH.t).

Definition name := (|Blake2BModule|).(S.HASH.name).

Definition title := (|Blake2BModule|).(S.HASH.title).

Definition pp := (|Blake2BModule|).(S.HASH.pp).

Definition pp_short := (|Blake2BModule|).(S.HASH.pp_short).

Definition op_eq := (|Blake2BModule|).(S.HASH.op_eq).

Definition op_ltgt := (|Blake2BModule|).(S.HASH.op_ltgt).

Definition op_lt := (|Blake2BModule|).(S.HASH.op_lt).

Definition op_lteq := (|Blake2BModule|).(S.HASH.op_lteq).

Definition op_gteq := (|Blake2BModule|).(S.HASH.op_gteq).

Definition op_gt := (|Blake2BModule|).(S.HASH.op_gt).

Definition compare := (|Blake2BModule|).(S.HASH.compare).

Definition equal := (|Blake2BModule|).(S.HASH.equal).

Definition max := (|Blake2BModule|).(S.HASH.max).

Definition min := (|Blake2BModule|).(S.HASH.min).

Definition hash_bytes := (|Blake2BModule|).(S.HASH.hash_bytes).

Definition hash_string := (|Blake2BModule|).(S.HASH.hash_string).

Definition zero := (|Blake2BModule|).(S.HASH.zero).

Definition size := (|Blake2BModule|).(S.HASH.size).

Definition to_bytes := (|Blake2BModule|).(S.HASH.to_bytes).

Definition of_bytes_opt := (|Blake2BModule|).(S.HASH.of_bytes_opt).

Definition of_bytes_exn := (|Blake2BModule|).(S.HASH.of_bytes_exn).

Definition to_b58check := (|Blake2BModule|).(S.HASH.to_b58check).

Definition to_short_b58check := (|Blake2BModule|).(S.HASH.to_short_b58check).

Definition of_b58check_exn := (|Blake2BModule|).(S.HASH.of_b58check_exn).

Definition of_b58check_opt := (|Blake2BModule|).(S.HASH.of_b58check_opt).

Definition b58check_encoding := (|Blake2BModule|).(S.HASH.b58check_encoding).

Definition encoding := (|Blake2BModule|).(S.HASH.encoding).

Definition rpc_arg := (|Blake2BModule|).(S.HASH.rpc_arg).

Definition to_path := (|Blake2BModule|).(S.HASH.to_path).

Definition of_path := (|Blake2BModule|).(S.HASH.of_path).

Definition of_path_exn := (|Blake2BModule|).(S.HASH.of_path_exn).

Definition prefix_path := (|Blake2BModule|).(S.HASH.prefix_path).

Definition path_length := (|Blake2BModule|).(S.HASH.path_length).

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Contract_repr

  • OCaml size: 232 lines
  • Coq size: 253 lines (+9% compared to OCaml)
contract_repr.ml 19 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t =
  | Implicit of Signature.Public_key_hash.t
  | Originated of Contract_hash.t

module CompareModule = Compare.Make (struct
  type nonrec t = t

  let compare l1 l2 =
    match (l1, l2) with
    | (Implicit pkh1, Implicit pkh2) ->
        Signature.Public_key_hash.compare pkh1 pkh2
    | (Originated h1, Originated h2) ->
        Contract_hash.compare h1 h2
    | (Implicit _, Originated _) ->
        -1
    | (Originated _, Implicit _) ->
        1
end)

include CompareModule

type contract = t

type error += Invalid_contract_notation of string (* `Permanent *)

let to_b58check = function
  | Implicit pbk ->
      Signature.Public_key_hash.to_b58check pbk
  | Originated h ->
      Contract_hash.to_b58check h

let of_b58check s =
  match Base58.decode s with
  | Some (Ed25519.Public_key_hash.Data h) ->
      ok (Implicit (Signature.Ed25519Hash h))
  | Some (Secp256k1.Public_key_hash.Data h) ->
      ok (Implicit (Signature.Secp256k1Hash h))
  | Some (P256.Public_key_hash.Data h) ->
      ok (Implicit (Signature.P256Hash h))
  | Some (Contract_hash.Data h) ->
      ok (Originated h)
  | _ ->
      error (Invalid_contract_notation s)

let pp ppf = function
  | Implicit pbk ->
      Signature.Public_key_hash.pp ppf pbk
  | Originated h ->
      Contract_hash.pp ppf h

let pp_short ppf = function
  | Implicit pbk ->
      Signature.Public_key_hash.pp_short ppf pbk
  | Originated h ->
      Contract_hash.pp_short ppf h

let[@coq_axiom] encoding =
  let open Data_encoding in
  def
    "contract_id"
    ~title:"A contract handle"
    ~description:
      "A contract notation as given to an RPC or inside scripts. Can be a \
       base58 implicit contract hash or a base58 originated contract hash."
  @@ splitted
       ~binary:
         (union
            ~tag_size:`Uint8
            [ case
                (Tag 0)
                ~title:"Implicit"
                Signature.Public_key_hash.encoding
                (function Implicit k -> Some k | _ -> None)
                (fun k -> Implicit k);
              case
                (Tag 1)
                (Fixed.add_padding Contract_hash.encoding 1)
                ~title:"Originated"
                (function Originated k -> Some k | _ -> None)
                (fun k -> Originated k) ])
       ~json:
         (conv
            to_b58check
            (fun s ->
              match of_b58check s with
              | Ok s ->
                  s
              | Error _ ->
                  Json.cannot_destruct "Invalid contract notation.")
            string)

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"contract.invalid_contract_notation"
    ~title:"Invalid contract notation"
    ~pp:(fun ppf x -> Format.fprintf ppf "Invalid contract notation %S" x)
    ~description:
      "A malformed contract notation was given to an RPC or in a script."
    (obj1 (req "notation" string))
    (function Invalid_contract_notation loc -> Some loc | _ -> None)
    (fun loc -> Invalid_contract_notation loc)

let implicit_contract id = Implicit id

let is_implicit = function Implicit m -> Some m | Originated _ -> None

let is_originated = function Implicit _ -> None | Originated h -> Some h

type origination_nonce = {
  operation_hash : Operation_hash.t;
  origination_index : int32;
}

let origination_nonce_encoding =
  let open Data_encoding in
  conv
    (fun {operation_hash; origination_index} ->
      (operation_hash, origination_index))
    (fun (operation_hash, origination_index) ->
      {operation_hash; origination_index})
  @@ obj2 (req "operation" Operation_hash.encoding) (dft "index" int32 0l)

let originated_contract nonce =
  let data =
    Data_encoding.Binary.to_bytes_exn origination_nonce_encoding nonce
  in
  Originated (Contract_hash.hash_bytes [data])

let originated_contracts
    ~since:{origination_index = first; operation_hash = first_hash}
    ~until:( {origination_index = last; operation_hash = last_hash} as
           origination_nonce ) =
  assert (Operation_hash.equal first_hash last_hash) ;
  let rec contracts acc origination_index =
    if Compare.Int32.(origination_index < first) then acc
    else
      let origination_nonce = {origination_nonce with origination_index} in
      let acc = originated_contract origination_nonce :: acc in
      contracts acc (Int32.pred origination_index)
  in
  contracts [] (Int32.pred last)

let initial_origination_nonce operation_hash =
  {operation_hash; origination_index = 0l}

let incr_origination_nonce nonce =
  let origination_index = Int32.succ nonce.origination_index in
  {nonce with origination_index}

let rpc_arg =
  let construct = to_b58check in
  let destruct hash =
    match of_b58check hash with
    | Error _ ->
        Error "Cannot parse contract id"
    | Ok contract ->
        Ok contract
  in
  RPC_arg.make
    ~descr:"A contract identifier encoded in b58check."
    ~name:"contract_id"
    ~construct
    ~destruct
    ()

module Index = struct
  type t = contract

  let path_length = 7

  let to_path c l =
    let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in
    let (`Hex key) = MBytes.to_hex raw_key in
    let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
    String.sub index_key 0 2 :: String.sub index_key 2 2
    :: String.sub index_key 4 2 :: String.sub index_key 6 2
    :: String.sub index_key 8 2 :: String.sub index_key 10 2 :: key :: l

  let of_path = function
    | []
    | [_]
    | [_; _]
    | [_; _; _]
    | [_; _; _; _]
    | [_; _; _; _; _]
    | [_; _; _; _; _; _]
    | _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ ->
        None
    | [index1; index2; index3; index4; index5; index6; key] ->
        let raw_key = MBytes.of_hex (`Hex key) in
        let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
        assert (Compare.String.(String.sub index_key 0 2 = index1)) ;
        assert (Compare.String.(String.sub index_key 2 2 = index2)) ;
        assert (Compare.String.(String.sub index_key 4 2 = index3)) ;
        assert (Compare.String.(String.sub index_key 6 2 = index4)) ;
        assert (Compare.String.(String.sub index_key 8 2 = index5)) ;
        assert (Compare.String.(String.sub index_key 10 2 = index6)) ;
        Data_encoding.Binary.of_bytes encoding raw_key

  let rpc_arg = rpc_arg

  let encoding = encoding

  let compare = compare
end
Contract_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Contract_hash.

Inductive t : Set :=
| Implicit : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> t
| Originated : Contract_hash.t -> t.

Definition CompareModule :=
  Compare.Make
    (let t := t in
    let compare (l1 : t) (l2 : t) : Z :=
      match (l1, l2) with
      | (Implicit pkh1, Implicit pkh2) =>
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.compare) pkh1 pkh2
      | (Originated h1, Originated h2) => Contract_hash.compare h1 h2
      | (Implicit _, Originated _) => (-1)
      | (Originated _, Implicit _) => 1
      end in
    existT _ _
      {|
        Compare.COMPARABLE.compare := compare
      |}).

Definition op_eq := (|CompareModule|).(Compare.S.op_eq).

Definition op_ltgt := (|CompareModule|).(Compare.S.op_ltgt).

Definition op_lt := (|CompareModule|).(Compare.S.op_lt).

Definition op_lteq := (|CompareModule|).(Compare.S.op_lteq).

Definition op_gteq := (|CompareModule|).(Compare.S.op_gteq).

Definition op_gt := (|CompareModule|).(Compare.S.op_gt).

Definition compare := (|CompareModule|).(Compare.S.compare).

Definition equal := (|CompareModule|).(Compare.S.equal).

Definition max := (|CompareModule|).(Compare.S.max).

Definition min := (|CompareModule|).(Compare.S.min).

Definition contract := t.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

Definition to_b58check (function_parameter : t) : string :=
  match function_parameter with
  | Implicit pbk =>
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.to_b58check) pbk
  | Originated h => Contract_hash.to_b58check h
  end.

Definition of_b58check (s : string) : Error_monad.tzresult t :=
  let '_ := Base58.decode s in
  Error_monad.__error_value extensible_type_value.

Definition pp (ppf : Format.formatter) (function_parameter : t) : unit :=
  match function_parameter with
  | Implicit pbk =>
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.pp) ppf pbk
  | Originated h => Contract_hash.pp ppf h
  end.

Definition pp_short (ppf : Format.formatter) (function_parameter : t) : unit :=
  match function_parameter with
  | Implicit pbk =>
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.pp_short) ppf pbk
  | Originated h => Contract_hash.pp_short ppf h
  end.

Definition encoding : Data_encoding.encoding t := axiom.

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition implicit_contract
  (id : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) : t := Implicit id.

Definition is_implicit (function_parameter : t)
  : option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) :=
  match function_parameter with
  | Implicit m => Some m
  | Originated _ => None
  end.

Definition is_originated (function_parameter : t) : option Contract_hash.t :=
  match function_parameter with
  | Implicit _ => None
  | Originated h => Some h
  end.

Module origination_nonce.
  Record record := Build {
    operation_hash : (|Operation_hash|).(S.HASH.t);
    origination_index : int32 }.
  Definition with_operation_hash operation_hash (r : record) :=
    Build operation_hash r.(origination_index).
  Definition with_origination_index origination_index (r : record) :=
    Build r.(operation_hash) origination_index.
End origination_nonce.
Definition origination_nonce := origination_nonce.record.

Definition origination_nonce_encoding
  : Data_encoding.encoding origination_nonce :=
  Pervasives.op_atat
    (let arg :=
      Data_encoding.conv
        (fun function_parameter =>
          let '{|
            origination_nonce.operation_hash := operation_hash;
              origination_nonce.origination_index := origination_index
              |} := function_parameter in
          (operation_hash, origination_index))
        (fun function_parameter =>
          let '(operation_hash, origination_index) := function_parameter in
          {| origination_nonce.operation_hash := operation_hash;
            origination_nonce.origination_index := origination_index |}) in
    fun eta => arg None eta)
    (Data_encoding.obj2
      (Data_encoding.req None None "operation"
        (|Operation_hash|).(S.HASH.encoding))
      (Data_encoding.dft None None "index" Data_encoding.__int32_value
        (* ❌ Constant of type int32 is converted to int *)
        0)).

Definition originated_contract (__nonce_value : origination_nonce) : t :=
  let data :=
    Data_encoding.Binary.to_bytes_exn origination_nonce_encoding __nonce_value
    in
  Originated (Contract_hash.hash_bytes None [ data ]).

Definition originated_contracts (function_parameter : origination_nonce)
  : origination_nonce -> list t :=
  let '{|
    origination_nonce.operation_hash := first_hash;
      origination_nonce.origination_index := first
      |} := function_parameter in
  fun function_parameter =>
    let
      '{|
        origination_nonce.operation_hash := last_hash;
          origination_nonce.origination_index := last
          |} as origination_nonce := function_parameter in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    (* ❌ instruction_sequence ";" *)
    let fix contracts
      (acc : list t) (origination_index : (|Compare.Int32|).(Compare.S.t))
      {struct acc} : list t :=
      if (|Compare.Int32|).(Compare.S.op_lt) origination_index first then
        acc
      else
        let origination_nonce :=
          origination_nonce.with_origination_index origination_index
            origination_nonce in
        let acc := cons (originated_contract origination_nonce) acc in
        contracts acc (Int32.pred origination_index) in
    contracts [] (Int32.pred last).

Definition initial_origination_nonce
  (operation_hash : (|Operation_hash|).(S.HASH.t)) : origination_nonce :=
  {| origination_nonce.operation_hash := operation_hash;
    origination_nonce.origination_index :=
      (* ❌ Constant of type int32 is converted to int *)
      0 |}.

Definition incr_origination_nonce (__nonce_value : origination_nonce)
  : origination_nonce :=
  let origination_index :=
    Int32.succ (origination_nonce.origination_index __nonce_value) in
  origination_nonce.with_origination_index origination_index __nonce_value.

Definition rpc_arg : RPC_arg.arg t :=
  let construct := to_b58check in
  let destruct (__hash_value : string) : Pervasives.result t string :=
    match of_b58check __hash_value with
    | Pervasives.Error _ => Pervasives.Error "Cannot parse contract id"
    | Pervasives.Ok contract => Pervasives.Ok contract
    end in
  RPC_arg.make (Some "A contract identifier encoded in b58check.") "contract_id"
    destruct construct tt.

Module Index.
  Definition t := contract.
  
  Definition path_length : Z := 7.
  
  Definition to_path (c : t) (l : list string) : list string :=
    let raw_key := Data_encoding.Binary.to_bytes_exn encoding c in
    let 'MBytes.Hex key := MBytes.to_hex raw_key in
    let 'MBytes.Hex index_key := MBytes.to_hex (Raw_hashes.blake2b raw_key) in
    cons (String.sub index_key 0 2)
      (cons (String.sub index_key 2 2)
        (cons (String.sub index_key 4 2)
          (cons (String.sub index_key 6 2)
            (cons (String.sub index_key 8 2)
              (cons (String.sub index_key 10 2) (cons key l)))))).
  
  Definition of_path
    (function_parameter : list (|Compare.String|).(Compare.S.t)) : option t :=
    match function_parameter with
    |
      [] | cons _ [] | cons _ (cons _ []) | cons _ (cons _ (cons _ [])) |
      cons _ (cons _ (cons _ (cons _ []))) |
      cons _ (cons _ (cons _ (cons _ (cons _ [])))) |
      cons _ (cons _ (cons _ (cons _ (cons _ (cons _ []))))) |
      cons _ (cons _ (cons _ (cons _ (cons _ (cons _ (cons _ (cons _ _))))))) =>
      None
    |
      cons index1
        (cons index2
          (cons index3 (cons index4 (cons index5 (cons index6 (cons key []))))))
      =>
      let raw_key :=
        MBytes.of_hex
          (* ❌ Variants not supported *)
          (* ❌ `Hex *)
          (MBytes.Hex key) in
      let 'MBytes.Hex index_key := MBytes.to_hex (Raw_hashes.blake2b raw_key) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      (* ❌ instruction_sequence ";" *)
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      (* ❌ instruction_sequence ";" *)
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      (* ❌ instruction_sequence ";" *)
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      (* ❌ instruction_sequence ";" *)
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      (* ❌ instruction_sequence ";" *)
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      (* ❌ instruction_sequence ";" *)
      Data_encoding.Binary.of_bytes encoding raw_key
    end.
  
  Definition rpc_arg : RPC_arg.arg t := rpc_arg.
  
  Definition encoding : Data_encoding.encoding t := encoding.
  
  Definition compare : t -> t -> Z := compare.
End Index.

Contract_repr_mli

  • OCaml size: 80 lines
  • Coq size: 80 lines (+0% compared to OCaml)
contract_repr.mli 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = private
  | Implicit of Signature.Public_key_hash.t
  | Originated of Contract_hash.t

type contract = t

include Compare.S with type t := contract

(** {2 Implicit contracts} *)

val implicit_contract : Signature.Public_key_hash.t -> contract

val is_implicit : contract -> Signature.Public_key_hash.t option

(** {2 Originated contracts} *)

(** Originated contracts handles are crafted from the hash of the
    operation that triggered their origination (and nothing else).
    As a single operation can trigger several originations, the
    corresponding handles are forged from a deterministic sequence of
    nonces, initialized with the hash of the operation. *)
type origination_nonce

val originated_contract : origination_nonce -> contract

val originated_contracts :
  since:origination_nonce -> until:origination_nonce -> contract list

val initial_origination_nonce : Operation_hash.t -> origination_nonce

val incr_origination_nonce : origination_nonce -> origination_nonce

val is_originated : contract -> Contract_hash.t option

(** {2 Human readable notation} *)

type error += Invalid_contract_notation of string (* `Permanent *)

val to_b58check : contract -> string

val of_b58check : string -> contract tzresult

val pp : Format.formatter -> contract -> unit

val pp_short : Format.formatter -> contract -> unit

(** {2 Serializers} *)

val encoding : contract Data_encoding.t

val origination_nonce_encoding : origination_nonce Data_encoding.t

val rpc_arg : contract RPC_arg.arg

module Index : Storage_description.INDEX with type t = t
Contract_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Contract_hash.
Require Tezos.Storage_description.

Inductive t : Set :=
| Implicit : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> t
| Originated : Contract_hash.t -> t.

Definition contract := t.

Parameter Included_S : {_ : unit & Compare.S.signature contract}.

Definition op_eq := (|Included_S|).(Compare.S.op_eq).

Definition op_ltgt := (|Included_S|).(Compare.S.op_ltgt).

Definition op_lt := (|Included_S|).(Compare.S.op_lt).

Definition op_lteq := (|Included_S|).(Compare.S.op_lteq).

Definition op_gteq := (|Included_S|).(Compare.S.op_gteq).

Definition op_gt := (|Included_S|).(Compare.S.op_gt).

Definition compare := (|Included_S|).(Compare.S.compare).

Definition equal := (|Included_S|).(Compare.S.equal).

Definition max := (|Included_S|).(Compare.S.max).

Definition min := (|Included_S|).(Compare.S.min).

Parameter implicit_contract :
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> contract.

Parameter is_implicit :
  contract -> option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t).

Parameter origination_nonce : Set.

Parameter originated_contract : origination_nonce -> contract.

Parameter originated_contracts :
  origination_nonce -> origination_nonce -> list contract.

Parameter initial_origination_nonce :
  (|Operation_hash|).(S.HASH.t) -> origination_nonce.

Parameter incr_origination_nonce : origination_nonce -> origination_nonce.

Parameter is_originated : contract -> option Contract_hash.t.

(* extensible_type error *)

Parameter to_b58check : contract -> string.

Parameter of_b58check : string -> Error_monad.tzresult contract.

Parameter pp : Format.formatter -> contract -> unit.

Parameter pp_short : Format.formatter -> contract -> unit.

Parameter encoding : Data_encoding.t contract.

Parameter origination_nonce_encoding : Data_encoding.t origination_nonce.

Parameter rpc_arg : RPC_arg.arg contract.

Parameter Index : {_ : unit & Storage_description.INDEX.signature t}.

Contract_services

  • OCaml size: 425 lines
  • Coq size: 763 lines (+79% compared to OCaml)
contract_services.ml 224 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

let custom_root =
  ( RPC_path.(open_root / "context" / "contracts")
    : RPC_context.t RPC_path.context )

let big_map_root =
  ( RPC_path.(open_root / "context" / "big_maps")
    : RPC_context.t RPC_path.context )

type info = {
  balance : Tez.t;
  delegate : public_key_hash option;
  counter : counter option;
  script : Script.t option;
}

let info_encoding =
  let open Data_encoding in
  conv
    (fun {balance; delegate; script; counter} ->
      (balance, delegate, script, counter))
    (fun (balance, delegate, script, counter) ->
      {balance; delegate; script; counter})
  @@ obj4
       (req "balance" Tez.encoding)
       (opt "delegate" Signature.Public_key_hash.encoding)
       (opt "script" Script.encoding)
       (opt "counter" n)

module S = struct
  open Data_encoding

  let balance =
    RPC_service.get_service
      ~description:"Access the balance of a contract."
      ~query:RPC_query.empty
      ~output:Tez.encoding
      RPC_path.(custom_root /: Contract.rpc_arg / "balance")

  let manager_key =
    RPC_service.get_service
      ~description:"Access the manager of a contract."
      ~query:RPC_query.empty
      ~output:(option Signature.Public_key.encoding)
      RPC_path.(custom_root /: Contract.rpc_arg / "manager_key")

  let delegate =
    RPC_service.get_service
      ~description:"Access the delegate of a contract, if any."
      ~query:RPC_query.empty
      ~output:Signature.Public_key_hash.encoding
      RPC_path.(custom_root /: Contract.rpc_arg / "delegate")

  let counter =
    RPC_service.get_service
      ~description:"Access the counter of a contract, if any."
      ~query:RPC_query.empty
      ~output:z
      RPC_path.(custom_root /: Contract.rpc_arg / "counter")

  let script =
    RPC_service.get_service
      ~description:"Access the code and data of the contract."
      ~query:RPC_query.empty
      ~output:Script.encoding
      RPC_path.(custom_root /: Contract.rpc_arg / "script")

  let storage =
    RPC_service.get_service
      ~description:"Access the data of the contract."
      ~query:RPC_query.empty
      ~output:Script.expr_encoding
      RPC_path.(custom_root /: Contract.rpc_arg / "storage")

  let entrypoint_type =
    RPC_service.get_service
      ~description:"Return the type of the given entrypoint of the contract"
      ~query:RPC_query.empty
      ~output:Script.expr_encoding
      RPC_path.(
        custom_root /: Contract.rpc_arg / "entrypoints" /: RPC_arg.string)

  let list_entrypoints =
    RPC_service.get_service
      ~description:"Return the list of entrypoints of the contract"
      ~query:RPC_query.empty
      ~output:
        (obj2
           (dft
              "unreachable"
              (Data_encoding.list
                 (obj1
                    (req
                       "path"
                       (Data_encoding.list
                          Michelson_v1_primitives.prim_encoding))))
              [])
           (req "entrypoints" (assoc Script.expr_encoding)))
      RPC_path.(custom_root /: Contract.rpc_arg / "entrypoints")

  let contract_big_map_get_opt =
    RPC_service.post_service
      ~description:
        "Access the value associated with a key in a big map of the contract \
         (deprecated)."
      ~query:RPC_query.empty
      ~input:
        (obj2
           (req "key" Script.expr_encoding)
           (req "type" Script.expr_encoding))
      ~output:(option Script.expr_encoding)
      RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get")

  let big_map_get =
    RPC_service.get_service
      ~description:"Access the value associated with a key in a big map."
      ~query:RPC_query.empty
      ~output:Script.expr_encoding
      RPC_path.(big_map_root /: Big_map.rpc_arg /: Script_expr_hash.rpc_arg)

  let info =
    RPC_service.get_service
      ~description:"Access the complete status of a contract."
      ~query:RPC_query.empty
      ~output:info_encoding
      RPC_path.(custom_root /: Contract.rpc_arg)

  let list =
    RPC_service.get_service
      ~description:
        "All existing contracts (including non-empty default contracts)."
      ~query:RPC_query.empty
      ~output:(list Contract.encoding)
      custom_root
end

let register () =
  let open Services_registration in
  register0 S.list (fun ctxt () () -> Contract.list ctxt >>= return) ;
  let register_field s f =
    register1 s (fun ctxt contract () () ->
        Contract.exists ctxt contract
        >>=? function true -> f ctxt contract | false -> raise Not_found)
  in
  let register_opt_field s f =
    register_field s (fun ctxt a1 ->
        f ctxt a1 >>=? function None -> raise Not_found | Some v -> return v)
  in
  let do_big_map_get ctxt id key =
    let open Script_ir_translator in
    let ctxt = Gas.set_unlimited ctxt in
    Big_map.exists ctxt id
    >>=? fun (ctxt, types) ->
    match types with
    | None ->
        raise Not_found
    | Some (_, value_type) -> (
        Lwt.return
          (parse_ty
             ctxt
             ~legacy:true
             ~allow_big_map:false
             ~allow_operation:false
             ~allow_contract:true
             (Micheline.root value_type))
        >>=? fun (Ex_ty value_type, ctxt) ->
        Big_map.get_opt ctxt id key
        >>=? fun (_ctxt, value) ->
        match value with
        | None ->
            raise Not_found
        | Some value ->
            parse_data ctxt ~legacy:true value_type (Micheline.root value)
            >>=? fun (value, ctxt) ->
            unparse_data ctxt Readable value_type value
            >>=? fun (value, _ctxt) -> return (Micheline.strip_locations value)
        )
  in
  register_field S.balance Contract.get_balance ;
  register1 S.manager_key (fun ctxt contract () () ->
      match Contract.is_implicit contract with
      | None ->
          raise Not_found
      | Some mgr -> (
          Contract.is_manager_key_revealed ctxt mgr
          >>=? function
          | false ->
              return_none
          | true ->
              Contract.get_manager_key ctxt mgr >>=? return_some )) ;
  register_opt_field S.delegate Delegate.get ;
  register1 S.counter (fun ctxt contract () () ->
      match Contract.is_implicit contract with
      | None ->
          raise Not_found
      | Some mgr ->
          Contract.get_counter ctxt mgr) ;
  register_opt_field S.script (fun c v ->
      Contract.get_script c v >>=? fun (_, v) -> return v) ;
  register_opt_field S.storage (fun ctxt contract ->
      Contract.get_script ctxt contract
      >>=? fun (ctxt, script) ->
      match script with
      | None ->
          return_none
      | Some script ->
          let ctxt = Gas.set_unlimited ctxt in
          let open Script_ir_translator in
          parse_script ctxt ~legacy:true script
          >>=? fun (Ex_script script, ctxt) ->
          unparse_script ctxt Readable script
          >>=? fun (script, ctxt) ->
          Script.force_decode ctxt script.storage
          >>=? fun (storage, _ctxt) -> return_some storage) ;
  register2 S.entrypoint_type (fun ctxt v entrypoint () () ->
      Contract.get_script_code ctxt v
      >>=? fun (_, expr) ->
      match expr with
      | None ->
          raise Not_found
      | Some expr -> (
          let ctxt = Gas.set_unlimited ctxt in
          let legacy = true in
          let open Script_ir_translator in
          Script.force_decode ctxt expr
          >>=? fun (expr, _) ->
          Lwt.return
            ( parse_toplevel ~legacy expr
            >>? fun (arg_type, _, _, root_name) ->
            parse_ty
              ctxt
              ~legacy
              ~allow_big_map:true
              ~allow_operation:false
              ~allow_contract:true
              arg_type
            >>? fun (Ex_ty arg_type, _) ->
            Script_ir_translator.find_entrypoint ~root_name arg_type entrypoint
            )
          >>= function
          | Ok (_f, Ex_ty ty) ->
              unparse_ty ctxt ty
              >>=? fun (ty_node, _) ->
              return (Micheline.strip_locations ty_node)
          | Error _ ->
              raise Not_found )) ;
  register1 S.list_entrypoints (fun ctxt v () () ->
      Contract.get_script_code ctxt v
      >>=? fun (_, expr) ->
      match expr with
      | None ->
          raise Not_found
      | Some expr ->
          let ctxt = Gas.set_unlimited ctxt in
          let legacy = true in
          let open Script_ir_translator in
          Script.force_decode ctxt expr
          >>=? fun (expr, _) ->
          Lwt.return
            ( parse_toplevel ~legacy expr
            >>? fun (arg_type, _, _, root_name) ->
            parse_ty
              ctxt
              ~legacy
              ~allow_big_map:true
              ~allow_operation:false
              ~allow_contract:true
              arg_type
            >>? fun (Ex_ty arg_type, _) ->
            Script_ir_translator.list_entrypoints ~root_name arg_type ctxt )
          >>=? fun (unreachable_entrypoint, map) ->
          return
            ( unreachable_entrypoint,
              Entrypoints_map.fold
                (fun entry (_, ty) acc ->
                  (entry, Micheline.strip_locations ty) :: acc)
                map
                [] )) ;
  register1 S.contract_big_map_get_opt (fun ctxt contract () (key, key_type) ->
      Contract.get_script ctxt contract
      >>=? fun (ctxt, script) ->
      Lwt.return
        (Script_ir_translator.parse_packable_ty
           ctxt
           ~legacy:true
           (Micheline.root key_type))
      >>=? fun (Ex_ty key_type, ctxt) ->
      Script_ir_translator.parse_data
        ctxt
        ~legacy:true
        key_type
        (Micheline.root key)
      >>=? fun (key, ctxt) ->
      Script_ir_translator.hash_data ctxt key_type key
      >>=? fun (key, ctxt) ->
      match script with
      | None ->
          raise Not_found
      | Some script ->
          let ctxt = Gas.set_unlimited ctxt in
          let open Script_ir_translator in
          parse_script ctxt ~legacy:true script
          >>=? fun (Ex_script script, ctxt) ->
          Script_ir_translator.collect_big_maps
            ctxt
            script.storage_type
            script.storage
          >>=? fun (ids, _ctxt) ->
          let ids = Script_ir_translator.list_of_big_map_ids ids in
          let rec find = function
            | [] ->
                return_none
            | (id : Z.t) :: ids -> (
              try do_big_map_get ctxt id key >>=? return_some
              with Not_found -> find ids )
          in
          find ids) ;
  register2 S.big_map_get (fun ctxt id key () () -> do_big_map_get ctxt id key) ;
  register_field S.info (fun ctxt contract ->
      Contract.get_balance ctxt contract
      >>=? fun balance ->
      Delegate.get ctxt contract
      >>=? fun delegate ->
      ( match Contract.is_implicit contract with
      | Some manager ->
          Contract.get_counter ctxt manager
          >>=? fun counter -> return_some counter
      | None ->
          return None )
      >>=? fun counter ->
      Contract.get_script ctxt contract
      >>=? fun (ctxt, script) ->
      ( match script with
      | None ->
          return (None, ctxt)
      | Some script ->
          let ctxt = Gas.set_unlimited ctxt in
          let open Script_ir_translator in
          parse_script ctxt ~legacy:true script
          >>=? fun (Ex_script script, ctxt) ->
          unparse_script ctxt Readable script
          >>=? fun (script, ctxt) -> return (Some script, ctxt) )
      >>=? fun (script, _ctxt) -> return {balance; delegate; script; counter})

let list ctxt block = RPC_context.make_call0 S.list ctxt block () ()

let info ctxt block contract =
  RPC_context.make_call1 S.info ctxt block contract () ()

let balance ctxt block contract =
  RPC_context.make_call1 S.balance ctxt block contract () ()

let manager_key ctxt block mgr =
  RPC_context.make_call1
    S.manager_key
    ctxt
    block
    (Contract.implicit_contract mgr)
    ()
    ()

let delegate ctxt block contract =
  RPC_context.make_call1 S.delegate ctxt block contract () ()

let delegate_opt ctxt block contract =
  RPC_context.make_opt_call1 S.delegate ctxt block contract () ()

let counter ctxt block mgr =
  RPC_context.make_call1
    S.counter
    ctxt
    block
    (Contract.implicit_contract mgr)
    ()
    ()

let script ctxt block contract =
  RPC_context.make_call1 S.script ctxt block contract () ()

let script_opt ctxt block contract =
  RPC_context.make_opt_call1 S.script ctxt block contract () ()

let storage ctxt block contract =
  RPC_context.make_call1 S.storage ctxt block contract () ()

let entrypoint_type ctxt block contract entrypoint =
  RPC_context.make_call2 S.entrypoint_type ctxt block contract entrypoint () ()

let list_entrypoints ctxt block contract =
  RPC_context.make_call1 S.list_entrypoints ctxt block contract () ()

let storage_opt ctxt block contract =
  RPC_context.make_opt_call1 S.storage ctxt block contract () ()

let big_map_get ctxt block id key =
  RPC_context.make_call2 S.big_map_get ctxt block id key () ()

let contract_big_map_get_opt ctxt block contract key =
  RPC_context.make_call1 S.contract_big_map_get_opt ctxt block contract () key
Contract_services.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Michelson_v1_primitives.
Require Tezos.Script_expr_hash.
Require Tezos.Script_ir_translator.
Require Tezos.Services_registration.

Import Alpha_context.

Definition custom_root : RPC_path.context RPC_context.t :=
  RPC_path.op_div (RPC_path.op_div RPC_path.open_root "context") "contracts".

Definition big_map_root : RPC_path.context RPC_context.t :=
  RPC_path.op_div (RPC_path.op_div RPC_path.open_root "context") "big_maps".

Module info.
  Record record := Build {
    balance : Alpha_context.Tez.t;
    delegate : option Alpha_context.public_key_hash;
    counter : option Alpha_context.counter;
    script : option Alpha_context.Script.t }.
  Definition with_balance balance (r : record) :=
    Build balance r.(delegate) r.(counter) r.(script).
  Definition with_delegate delegate (r : record) :=
    Build r.(balance) delegate r.(counter) r.(script).
  Definition with_counter counter (r : record) :=
    Build r.(balance) r.(delegate) counter r.(script).
  Definition with_script script (r : record) :=
    Build r.(balance) r.(delegate) r.(counter) script.
End info.
Definition info := info.record.

Definition info_encoding : Data_encoding.encoding info :=
  Pervasives.op_atat
    (let arg :=
      Data_encoding.conv
        (fun function_parameter =>
          let '{|
            info.balance := balance;
              info.delegate := delegate;
              info.counter := counter;
              info.script := script
              |} := function_parameter in
          (balance, delegate, script, counter))
        (fun function_parameter =>
          let '(balance, delegate, script, counter) := function_parameter in
          {| info.balance := balance; info.delegate := delegate;
            info.counter := counter; info.script := script |}) in
    fun eta => arg None eta)
    (Data_encoding.obj4
      (Data_encoding.req None None "balance" Alpha_context.Tez.encoding)
      (Data_encoding.opt None None "delegate"
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding))
      (Data_encoding.opt None None "script" Alpha_context.Script.encoding)
      (Data_encoding.opt None None "counter" Data_encoding.n)).

Module S.
  Import Data_encoding.
  
  Definition balance
    : RPC_service.service (* `GET *) unit RPC_context.t
      (RPC_context.t * Alpha_context.Contract.contract) unit unit
      Alpha_context.Tez.t :=
    RPC_service.get_service (Some "Access the balance of a contract.")
      RPC_query.empty Alpha_context.Tez.encoding
      (RPC_path.op_div
        (RPC_path.op_divcolon custom_root Alpha_context.Contract.rpc_arg)
        "balance").
  
  Definition manager_key
    : RPC_service.service (* `GET *) unit RPC_context.t
      (RPC_context.t * Alpha_context.Contract.contract) unit unit
      (option (|Signature.Public_key|).(S.SPublic_key.t)) :=
    RPC_service.get_service (Some "Access the manager of a contract.")
      RPC_query.empty
      (Data_encoding.__option_value
        (|Signature.Public_key|).(S.SPublic_key.encoding))
      (RPC_path.op_div
        (RPC_path.op_divcolon custom_root Alpha_context.Contract.rpc_arg)
        "manager_key").
  
  Definition delegate
    : RPC_service.service (* `GET *) unit RPC_context.t
      (RPC_context.t * Alpha_context.Contract.contract) unit unit
      (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) :=
    RPC_service.get_service (Some "Access the delegate of a contract, if any.")
      RPC_query.empty
      (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding)
      (RPC_path.op_div
        (RPC_path.op_divcolon custom_root Alpha_context.Contract.rpc_arg)
        "delegate").
  
  Definition counter
    : RPC_service.service (* `GET *) unit RPC_context.t
      (RPC_context.t * Alpha_context.Contract.contract) unit unit Z.t :=
    RPC_service.get_service (Some "Access the counter of a contract, if any.")
      RPC_query.empty Data_encoding.z
      (RPC_path.op_div
        (RPC_path.op_divcolon custom_root Alpha_context.Contract.rpc_arg)
        "counter").
  
  Definition script
    : RPC_service.service (* `GET *) unit RPC_context.t
      (RPC_context.t * Alpha_context.Contract.contract) unit unit
      Alpha_context.Script.t :=
    RPC_service.get_service (Some "Access the code and data of the contract.")
      RPC_query.empty Alpha_context.Script.encoding
      (RPC_path.op_div
        (RPC_path.op_divcolon custom_root Alpha_context.Contract.rpc_arg)
        "script").
  
  Definition storage
    : RPC_service.service (* `GET *) unit RPC_context.t
      (RPC_context.t * Alpha_context.Contract.contract) unit unit
      Alpha_context.Script.expr :=
    RPC_service.get_service (Some "Access the data of the contract.")
      RPC_query.empty Alpha_context.Script.expr_encoding
      (RPC_path.op_div
        (RPC_path.op_divcolon custom_root Alpha_context.Contract.rpc_arg)
        "storage").
  
  Definition entrypoint_type
    : RPC_service.service (* `GET *) unit RPC_context.t
      ((RPC_context.t * Alpha_context.Contract.contract) * string) unit unit
      Alpha_context.Script.expr :=
    RPC_service.get_service
      (Some "Return the type of the given entrypoint of the contract")
      RPC_query.empty Alpha_context.Script.expr_encoding
      (RPC_path.op_divcolon
        (RPC_path.op_div
          (RPC_path.op_divcolon custom_root Alpha_context.Contract.rpc_arg)
          "entrypoints") RPC_arg.__string_value).
  
  Definition list_entrypoints
    : RPC_service.service (* `GET *) unit RPC_context.t
      (RPC_context.t * Alpha_context.Contract.contract) unit unit
      (list (list Michelson_v1_primitives.prim) *
        list (string * Alpha_context.Script.expr)) :=
    RPC_service.get_service
      (Some "Return the list of entrypoints of the contract") RPC_query.empty
      (Data_encoding.obj2
        (Data_encoding.dft None None "unreachable"
          (Data_encoding.__list_value None
            (Data_encoding.obj1
              (Data_encoding.req None None "path"
                (Data_encoding.__list_value None
                  Michelson_v1_primitives.prim_encoding)))) [])
        (Data_encoding.req None None "entrypoints"
          (Data_encoding.assoc Alpha_context.Script.expr_encoding)))
      (RPC_path.op_div
        (RPC_path.op_divcolon custom_root Alpha_context.Contract.rpc_arg)
        "entrypoints").
  
  Definition contract_big_map_get_opt
    : RPC_service.service (* `POST *) unit RPC_context.t
      (RPC_context.t * Alpha_context.Contract.contract) unit
      (Alpha_context.Script.expr * Alpha_context.Script.expr)
      (option Alpha_context.Script.expr) :=
    RPC_service.post_service
      (Some
        "Access the value associated with a key in a big map of the contract (deprecated).")
      RPC_query.empty
      (Data_encoding.obj2
        (Data_encoding.req None None "key" Alpha_context.Script.expr_encoding)
        (Data_encoding.req None None "type" Alpha_context.Script.expr_encoding))
      (Data_encoding.__option_value Alpha_context.Script.expr_encoding)
      (RPC_path.op_div
        (RPC_path.op_divcolon custom_root Alpha_context.Contract.rpc_arg)
        "big_map_get").
  
  Definition big_map_get
    : RPC_service.service (* `GET *) unit RPC_context.t
      ((RPC_context.t * Alpha_context.Big_map.id) * Script_expr_hash.t) unit
      unit Alpha_context.Script.expr :=
    RPC_service.get_service
      (Some "Access the value associated with a key in a big map.")
      RPC_query.empty Alpha_context.Script.expr_encoding
      (RPC_path.op_divcolon
        (RPC_path.op_divcolon big_map_root Alpha_context.Big_map.rpc_arg)
        Script_expr_hash.rpc_arg).
  
  Definition info
    : RPC_service.service (* `GET *) unit RPC_context.t
      (RPC_context.t * Alpha_context.Contract.contract) unit unit info :=
    RPC_service.get_service (Some "Access the complete status of a contract.")
      RPC_query.empty info_encoding
      (RPC_path.op_divcolon custom_root Alpha_context.Contract.rpc_arg).
  
  Definition __list_value
    : RPC_service.service (* `GET *) unit RPC_context.t RPC_context.t unit unit
      (list Alpha_context.Contract.t) :=
    RPC_service.get_service
      (Some "All existing contracts (including non-empty default contracts).")
      RPC_query.empty
      (Data_encoding.__list_value None Alpha_context.Contract.encoding)
      custom_root.
End S.

Definition register (function_parameter : unit) : unit :=
  let '_ := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  let register_field {A : Set}
    (s :
      RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) Updater.rpc_context
        (Updater.rpc_context * Alpha_context.Contract.contract) unit unit A)
    (f :
      Alpha_context.t -> Alpha_context.Contract.contract ->
      Lwt.t (Error_monad.tzresult A)) : unit :=
    Services_registration.register1 s
      (fun ctxt =>
        fun contract =>
          fun function_parameter =>
            let '_ := function_parameter in
            fun function_parameter =>
              let '_ := function_parameter in
              Error_monad.op_gtgteqquestion
                (Alpha_context.Contract.__exists ctxt contract)
                (fun function_parameter =>
                  match function_parameter with
                  | true => f ctxt contract
                  | false => Pervasives.raise extensible_type_value
                  end)) in
  let register_opt_field {A : Set}
    (s :
      RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) Updater.rpc_context
        (Updater.rpc_context * Alpha_context.Contract.contract) unit unit A)
    (f :
      Alpha_context.t -> Alpha_context.Contract.contract ->
      Lwt.t (Error_monad.tzresult (option A))) : unit :=
    register_field s
      (fun ctxt =>
        fun a1 =>
          Error_monad.op_gtgteqquestion (f ctxt a1)
            (fun function_parameter =>
              match function_parameter with
              | None => Pervasives.raise extensible_type_value
              | Some v => Error_monad.__return v
              end)) in
  let do_big_map_get
    (ctxt : Alpha_context.context) (id : Alpha_context.Big_map.id)
    (key : Script_expr_hash.t)
    : Lwt.t
      (Error_monad.tzresult (Micheline.canonical Alpha_context.Script.prim)) :=
    let ctxt := Alpha_context.Gas.set_unlimited ctxt in
    Error_monad.op_gtgteqquestion (Alpha_context.Big_map.__exists ctxt id)
      (fun function_parameter =>
        let '(ctxt, types) := function_parameter in
        match types with
        | None => Pervasives.raise extensible_type_value
        | Some (_, value_type) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Script_ir_translator.parse_ty ctxt true false false true
                (Micheline.root value_type)))
            (fun function_parameter =>
              let '(Script_ir_translator.Ex_ty value_type, ctxt) :=
                function_parameter in
              Error_monad.op_gtgteqquestion
                (Alpha_context.Big_map.get_opt ctxt id key)
                (fun function_parameter =>
                  let '(_ctxt, value) := function_parameter in
                  match value with
                  | None => Pervasives.raise extensible_type_value
                  | Some value =>
                    Error_monad.op_gtgteqquestion
                      (Script_ir_translator.parse_data None ctxt true value_type
                        (Micheline.root value))
                      (fun function_parameter =>
                        let '(value, ctxt) := function_parameter in
                        Error_monad.op_gtgteqquestion
                          (Script_ir_translator.unparse_data ctxt
                            Script_ir_translator.Readable value_type value)
                          (fun function_parameter =>
                            let '(value, _ctxt) := function_parameter in
                            Error_monad.__return
                              (Micheline.strip_locations value)))
                  end))
        end) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  register_field S.info
    (fun ctxt =>
      fun contract =>
        Error_monad.op_gtgteqquestion
          (Alpha_context.Contract.get_balance ctxt contract)
          (fun balance =>
            Error_monad.op_gtgteqquestion
              (Alpha_context.Delegate.get ctxt contract)
              (fun delegate =>
                Error_monad.op_gtgteqquestion
                  match Alpha_context.Contract.is_implicit contract with
                  | Some manager =>
                    Error_monad.op_gtgteqquestion
                      (Alpha_context.Contract.get_counter ctxt manager)
                      (fun counter => Error_monad.return_some counter)
                  | None => Error_monad.__return None
                  end
                  (fun counter =>
                    Error_monad.op_gtgteqquestion
                      (Alpha_context.Contract.get_script ctxt contract)
                      (fun function_parameter =>
                        let '(ctxt, script) := function_parameter in
                        Error_monad.op_gtgteqquestion
                          match script with
                          | None => Error_monad.__return (None, ctxt)
                          | Some script =>
                            let ctxt := Alpha_context.Gas.set_unlimited ctxt in
                            Error_monad.op_gtgteqquestion
                              (Script_ir_translator.parse_script None ctxt true
                                script)
                              (fun function_parameter =>
                                let
                                  '(Script_ir_translator.Ex_script script, ctxt) :=
                                  function_parameter in
                                Error_monad.op_gtgteqquestion
                                  (Script_ir_translator.unparse_script ctxt
                                    Script_ir_translator.Readable script)
                                  (fun function_parameter =>
                                    let '(script, ctxt) := function_parameter in
                                    Error_monad.__return ((Some script), ctxt)))
                          end
                          (fun function_parameter =>
                            let '(script, _ctxt) := function_parameter in
                            Error_monad.__return
                              {| info.balance := balance;
                                info.delegate := delegate;
                                info.counter := counter; info.script := script
                                |})))))).

Definition __list_value {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  : Lwt.t (Error_monad.shell_tzresult (list Alpha_context.Contract.t)) :=
  RPC_context.make_call0 S.__list_value ctxt block tt tt.

Definition info {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (contract : Alpha_context.Contract.contract)
  : Lwt.t (Error_monad.shell_tzresult info) :=
  RPC_context.make_call1 S.info ctxt block contract tt tt.

Definition balance {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (contract : Alpha_context.Contract.contract)
  : Lwt.t (Error_monad.shell_tzresult Alpha_context.Tez.t) :=
  RPC_context.make_call1 S.balance ctxt block contract tt tt.

Definition manager_key {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (mgr : Alpha_context.public_key_hash)
  : Lwt.t
    (Error_monad.shell_tzresult
      (option (|Signature.Public_key|).(S.SPublic_key.t))) :=
  RPC_context.make_call1 S.manager_key ctxt block
    (Alpha_context.Contract.implicit_contract mgr) tt tt.

Definition delegate {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (contract : Alpha_context.Contract.contract)
  : Lwt.t
    (Error_monad.shell_tzresult
      (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) :=
  RPC_context.make_call1 S.delegate ctxt block contract tt tt.

Definition delegate_opt {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (contract : Alpha_context.Contract.contract)
  : Lwt.t
    (Error_monad.shell_tzresult
      (option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))) :=
  RPC_context.make_opt_call1 S.delegate ctxt block contract tt tt.

Definition counter {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (mgr : Alpha_context.public_key_hash)
  : Lwt.t (Error_monad.shell_tzresult Z.t) :=
  RPC_context.make_call1 S.counter ctxt block
    (Alpha_context.Contract.implicit_contract mgr) tt tt.

Definition script {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (contract : Alpha_context.Contract.contract)
  : Lwt.t (Error_monad.shell_tzresult Alpha_context.Script.t) :=
  RPC_context.make_call1 S.script ctxt block contract tt tt.

Definition script_opt {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (contract : Alpha_context.Contract.contract)
  : Lwt.t (Error_monad.shell_tzresult (option Alpha_context.Script.t)) :=
  RPC_context.make_opt_call1 S.script ctxt block contract tt tt.

Definition storage {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (contract : Alpha_context.Contract.contract)
  : Lwt.t (Error_monad.shell_tzresult Alpha_context.Script.expr) :=
  RPC_context.make_call1 S.storage ctxt block contract tt tt.

Definition entrypoint_type {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (contract : Alpha_context.Contract.contract) (entrypoint : string)
  : Lwt.t (Error_monad.shell_tzresult Alpha_context.Script.expr) :=
  RPC_context.make_call2 S.entrypoint_type ctxt block contract entrypoint tt tt.

Definition list_entrypoints {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (contract : Alpha_context.Contract.contract)
  : Lwt.t
    (Error_monad.shell_tzresult
      (list (list Michelson_v1_primitives.prim) *
        list (string * Alpha_context.Script.expr))) :=
  RPC_context.make_call1 S.list_entrypoints ctxt block contract tt tt.

Definition storage_opt {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (contract : Alpha_context.Contract.contract)
  : Lwt.t (Error_monad.shell_tzresult (option Alpha_context.Script.expr)) :=
  RPC_context.make_opt_call1 S.storage ctxt block contract tt tt.

Definition big_map_get {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (id : Alpha_context.Big_map.id) (key : Script_expr_hash.t)
  : Lwt.t (Error_monad.shell_tzresult Alpha_context.Script.expr) :=
  RPC_context.make_call2 S.big_map_get ctxt block id key tt tt.

Definition contract_big_map_get_opt {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (contract : Alpha_context.Contract.contract)
  (key : Alpha_context.Script.expr * Alpha_context.Script.expr)
  : Lwt.t (Error_monad.shell_tzresult (option Alpha_context.Script.expr)) :=
  RPC_context.make_call1 S.contract_big_map_get_opt ctxt block contract tt key.

Contract_services_mli

  • OCaml size: 119 lines
  • Coq size: 385 lines (+223% compared to OCaml)
contract_services.mli 195 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

val list : 'a #RPC_context.simple -> 'a -> Contract.t list shell_tzresult Lwt.t

type info = {
  balance : Tez.t;
  delegate : public_key_hash option;
  counter : counter option;
  script : Script.t option;
}

val info_encoding : info Data_encoding.t

val info :
  'a #RPC_context.simple -> 'a -> Contract.t -> info shell_tzresult Lwt.t

val balance :
  'a #RPC_context.simple -> 'a -> Contract.t -> Tez.t shell_tzresult Lwt.t

val manager_key :
  'a #RPC_context.simple ->
  'a ->
  public_key_hash ->
  public_key option shell_tzresult Lwt.t

val delegate :
  'a #RPC_context.simple ->
  'a ->
  Contract.t ->
  public_key_hash shell_tzresult Lwt.t

val delegate_opt :
  'a #RPC_context.simple ->
  'a ->
  Contract.t ->
  public_key_hash option shell_tzresult Lwt.t

val counter :
  'a #RPC_context.simple ->
  'a ->
  public_key_hash ->
  counter shell_tzresult Lwt.t

val script :
  'a #RPC_context.simple -> 'a -> Contract.t -> Script.t shell_tzresult Lwt.t

val script_opt :
  'a #RPC_context.simple ->
  'a ->
  Contract.t ->
  Script.t option shell_tzresult Lwt.t

val storage :
  'a #RPC_context.simple ->
  'a ->
  Contract.t ->
  Script.expr shell_tzresult Lwt.t

val entrypoint_type :
  'a #RPC_context.simple ->
  'a ->
  Contract.t ->
  string ->
  Script.expr shell_tzresult Lwt.t

val list_entrypoints :
  'a #RPC_context.simple ->
  'a ->
  Contract.t ->
  (Michelson_v1_primitives.prim list list * (string * Script.expr) list)
  shell_tzresult
  Lwt.t

val storage_opt :
  'a #RPC_context.simple ->
  'a ->
  Contract.t ->
  Script.expr option shell_tzresult Lwt.t

val big_map_get :
  'a #RPC_context.simple ->
  'a ->
  Z.t ->
  Script_expr_hash.t ->
  Script.expr shell_tzresult Lwt.t

val contract_big_map_get_opt :
  'a #RPC_context.simple ->
  'a ->
  Contract.t ->
  Script.expr * Script.expr ->
  Script.expr option shell_tzresult Lwt.t

val register : unit -> unit
Contract_services_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Michelson_v1_primitives.
Require Tezos.Script_expr_hash.

Parameter __list_value : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a ->
  Lwt.t (Error_monad.shell_tzresult (list Alpha_context.Contract.t)).

Module info.
  Record record := Build {
    balance : Alpha_context.Tez.t;
    delegate : option Alpha_context.public_key_hash;
    counter : option Alpha_context.counter;
    script : option Alpha_context.Script.t }.
  Definition with_balance balance (r : record) :=
    Build balance r.(delegate) r.(counter) r.(script).
  Definition with_delegate delegate (r : record) :=
    Build r.(balance) delegate r.(counter) r.(script).
  Definition with_counter counter (r : record) :=
    Build r.(balance) r.(delegate) counter r.(script).
  Definition with_script script (r : record) :=
    Build r.(balance) r.(delegate) r.(counter) script.
End info.
Definition info := info.record.

Parameter info_encoding : Data_encoding.t info.

Parameter info : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Alpha_context.Contract.t ->
  Lwt.t (Error_monad.shell_tzresult info).

Parameter balance : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Alpha_context.Contract.t ->
  Lwt.t (Error_monad.shell_tzresult Alpha_context.Tez.t).

Parameter manager_key : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Alpha_context.public_key_hash ->
  Lwt.t (Error_monad.shell_tzresult (option Alpha_context.public_key)).

Parameter delegate : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Alpha_context.Contract.t ->
  Lwt.t (Error_monad.shell_tzresult Alpha_context.public_key_hash).

Parameter delegate_opt : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Alpha_context.Contract.t ->
  Lwt.t (Error_monad.shell_tzresult (option Alpha_context.public_key_hash)).

Parameter counter : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Alpha_context.public_key_hash ->
  Lwt.t (Error_monad.shell_tzresult Alpha_context.counter).

Parameter script : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Alpha_context.Contract.t ->
  Lwt.t (Error_monad.shell_tzresult Alpha_context.Script.t).

Parameter script_opt : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Alpha_context.Contract.t ->
  Lwt.t (Error_monad.shell_tzresult (option Alpha_context.Script.t)).

Parameter storage : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Alpha_context.Contract.t ->
  Lwt.t (Error_monad.shell_tzresult Alpha_context.Script.expr).

Parameter entrypoint_type : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Alpha_context.Contract.t -> string ->
  Lwt.t (Error_monad.shell_tzresult Alpha_context.Script.expr).

Parameter list_entrypoints : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Alpha_context.Contract.t ->
  Lwt.t
    (Error_monad.shell_tzresult
      (list (list Michelson_v1_primitives.prim) *
        list (string * Alpha_context.Script.expr))).

Parameter storage_opt : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Alpha_context.Contract.t ->
  Lwt.t (Error_monad.shell_tzresult (option Alpha_context.Script.expr)).

Parameter big_map_get : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Z.t -> Script_expr_hash.t ->
  Lwt.t (Error_monad.shell_tzresult Alpha_context.Script.expr).

Parameter contract_big_map_get_opt : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Alpha_context.Contract.t ->
  Alpha_context.Script.expr * Alpha_context.Script.expr ->
  Lwt.t (Error_monad.shell_tzresult (option Alpha_context.Script.expr)).

Parameter register : unit -> unit.

Contract_storage

  • OCaml size: 733 lines
  • Coq size: 797 lines (+8% compared to OCaml)
contract_storage.ml 16 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error +=
  | Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t
  | (* `Temporary *)
      Counter_in_the_past of Contract_repr.contract * Z.t * Z.t
  | (* `Branch *)
      Counter_in_the_future of Contract_repr.contract * Z.t * Z.t
  | (* `Temporary *)
      Unspendable_contract of Contract_repr.contract
  | (* `Permanent *)
      Non_existing_contract of Contract_repr.contract
  | (* `Temporary *)
      Empty_implicit_contract of Signature.Public_key_hash.t
  | (* `Temporary *)
      Empty_transaction of Contract_repr.t (* `Temporary *)
  | Inconsistent_hash of
      Signature.Public_key.t
      * Signature.Public_key_hash.t
      * Signature.Public_key_hash.t
  | (* `Permanent *)
      Inconsistent_public_key of
      Signature.Public_key.t * Signature.Public_key.t
  | (* `Permanent *)
      Failure of string (* `Permanent *)
  | Previously_revealed_key of Contract_repr.t (* `Permanent *)
  | Unrevealed_manager_key of Contract_repr.t

(* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"contract.unspendable_contract"
    ~title:"Unspendable contract"
    ~description:
      "An operation tried to spend tokens from an unspendable contract"
    ~pp:(fun ppf c ->
      Format.fprintf
        ppf
        "The tokens of contract %a can only be spent by its script"
        Contract_repr.pp
        c)
    Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
    (function Unspendable_contract c -> Some c | _ -> None)
    (fun c -> Unspendable_contract c) ;
  register_error_kind
    `Temporary
    ~id:"contract.balance_too_low"
    ~title:"Balance too low"
    ~description:
      "An operation tried to spend more tokens than the contract has"
    ~pp:(fun ppf (c, b, a) ->
      Format.fprintf
        ppf
        "Balance of contract %a too low (%a) to spend %a"
        Contract_repr.pp
        c
        Tez_repr.pp
        b
        Tez_repr.pp
        a)
    Data_encoding.(
      obj3
        (req "contract" Contract_repr.encoding)
        (req "balance" Tez_repr.encoding)
        (req "amount" Tez_repr.encoding))
    (function Balance_too_low (c, b, a) -> Some (c, b, a) | _ -> None)
    (fun (c, b, a) -> Balance_too_low (c, b, a)) ;
  register_error_kind
    `Temporary
    ~id:"contract.counter_in_the_future"
    ~title:"Invalid counter (not yet reached) in a manager operation"
    ~description:"An operation assumed a contract counter in the future"
    ~pp:(fun ppf (contract, exp, found) ->
      Format.fprintf
        ppf
        "Counter %s not yet reached for contract %a (expected %s)"
        (Z.to_string found)
        Contract_repr.pp
        contract
        (Z.to_string exp))
    Data_encoding.(
      obj3
        (req "contract" Contract_repr.encoding)
        (req "expected" z)
        (req "found" z))
    (function Counter_in_the_future (c, x, y) -> Some (c, x, y) | _ -> None)
    (fun (c, x, y) -> Counter_in_the_future (c, x, y)) ;
  register_error_kind
    `Branch
    ~id:"contract.counter_in_the_past"
    ~title:"Invalid counter (already used) in a manager operation"
    ~description:"An operation assumed a contract counter in the past"
    ~pp:(fun ppf (contract, exp, found) ->
      Format.fprintf
        ppf
        "Counter %s already used for contract %a (expected %s)"
        (Z.to_string found)
        Contract_repr.pp
        contract
        (Z.to_string exp))
    Data_encoding.(
      obj3
        (req "contract" Contract_repr.encoding)
        (req "expected" z)
        (req "found" z))
    (function Counter_in_the_past (c, x, y) -> Some (c, x, y) | _ -> None)
    (fun (c, x, y) -> Counter_in_the_past (c, x, y)) ;
  register_error_kind
    `Temporary
    ~id:"contract.non_existing_contract"
    ~title:"Non existing contract"
    ~description:
      "A contract handle is not present in the context (either it never was \
       or it has been destroyed)"
    ~pp:(fun ppf contract ->
      Format.fprintf ppf "Contract %a does not exist" Contract_repr.pp contract)
    Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
    (function Non_existing_contract c -> Some c | _ -> None)
    (fun c -> Non_existing_contract c) ;
  register_error_kind
    `Permanent
    ~id:"contract.manager.inconsistent_hash"
    ~title:"Inconsistent public key hash"
    ~description:
      "A revealed manager public key is inconsistent with the announced hash"
    ~pp:(fun ppf (k, eh, ph) ->
      Format.fprintf
        ppf
        "The hash of the manager public key %s is not %a as announced but %a"
        (Signature.Public_key.to_b58check k)
        Signature.Public_key_hash.pp
        ph
        Signature.Public_key_hash.pp
        eh)
    Data_encoding.(
      obj3
        (req "public_key" Signature.Public_key.encoding)
        (req "expected_hash" Signature.Public_key_hash.encoding)
        (req "provided_hash" Signature.Public_key_hash.encoding))
    (function Inconsistent_hash (k, eh, ph) -> Some (k, eh, ph) | _ -> None)
    (fun (k, eh, ph) -> Inconsistent_hash (k, eh, ph)) ;
  register_error_kind
    `Permanent
    ~id:"contract.manager.inconsistent_public_key"
    ~title:"Inconsistent public key"
    ~description:
      "A provided manager public key is different with the public key stored \
       in the contract"
    ~pp:(fun ppf (eh, ph) ->
      Format.fprintf
        ppf
        "Expected manager public key %s but %s was provided"
        (Signature.Public_key.to_b58check ph)
        (Signature.Public_key.to_b58check eh))
    Data_encoding.(
      obj2
        (req "public_key" Signature.Public_key.encoding)
        (req "expected_public_key" Signature.Public_key.encoding))
    (function Inconsistent_public_key (eh, ph) -> Some (eh, ph) | _ -> None)
    (fun (eh, ph) -> Inconsistent_public_key (eh, ph)) ;
  register_error_kind
    `Permanent
    ~id:"contract.failure"
    ~title:"Contract storage failure"
    ~description:"Unexpected contract storage error"
    ~pp:(fun ppf s -> Format.fprintf ppf "Contract_storage.Failure %S" s)
    Data_encoding.(obj1 (req "message" string))
    (function Failure s -> Some s | _ -> None)
    (fun s -> Failure s) ;
  register_error_kind
    `Branch
    ~id:"contract.unrevealed_key"
    ~title:"Manager operation precedes key revelation"
    ~description:
      "One tried to apply a manager operation without revealing the manager \
       public key"
    ~pp:(fun ppf s ->
      Format.fprintf
        ppf
        "Unrevealed manager key for contract %a."
        Contract_repr.pp
        s)
    Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
    (function Unrevealed_manager_key s -> Some s | _ -> None)
    (fun s -> Unrevealed_manager_key s) ;
  register_error_kind
    `Branch
    ~id:"contract.previously_revealed_key"
    ~title:"Manager operation already revealed"
    ~description:"One tried to revealed twice a manager public key"
    ~pp:(fun ppf s ->
      Format.fprintf
        ppf
        "Previously revealed manager key for contract %a."
        Contract_repr.pp
        s)
    Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
    (function Previously_revealed_key s -> Some s | _ -> None)
    (fun s -> Previously_revealed_key s) ;
  register_error_kind
    `Branch
    ~id:"implicit.empty_implicit_contract"
    ~title:"Empty implicit contract"
    ~description:
      "No manager operations are allowed on an empty implicit contract."
    ~pp:(fun ppf implicit ->
      Format.fprintf
        ppf
        "Empty implicit contract (%a)"
        Signature.Public_key_hash.pp
        implicit)
    Data_encoding.(obj1 (req "implicit" Signature.Public_key_hash.encoding))
    (function Empty_implicit_contract c -> Some c | _ -> None)
    (fun c -> Empty_implicit_contract c) ;
  register_error_kind
    `Branch
    ~id:"contract.empty_transaction"
    ~title:"Empty transaction"
    ~description:"Forbidden to credit 0ꜩ to a contract without code."
    ~pp:(fun ppf contract ->
      Format.fprintf
        ppf
        "Transaction of 0ꜩ towards a contract without code are forbidden \
         (%a)."
        Contract_repr.pp
        contract)
    Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
    (function Empty_transaction c -> Some c | _ -> None)
    (fun c -> Empty_transaction c)

let failwith msg = fail (Failure msg)

type big_map_diff_item =
  | Update of {
      big_map : Z.t;
      diff_key : Script_repr.expr;
      diff_key_hash : Script_expr_hash.t;
      diff_value : Script_repr.expr option;
    }
  | Clear of Z.t
  | Copy of Z.t * Z.t
  | Alloc of {
      big_map : Z.t;
      key_type : Script_repr.expr;
      value_type : Script_repr.expr;
    }

type big_map_diff = big_map_diff_item list

let big_map_diff_item_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"update"
        (obj5
           (req "action" (constant "update"))
           (req "big_map" z)
           (req "key_hash" Script_expr_hash.encoding)
           (req "key" Script_repr.expr_encoding)
           (opt "value" Script_repr.expr_encoding))
        (function
          | Update {big_map; diff_key_hash; diff_key; diff_value} ->
              Some ((), big_map, diff_key_hash, diff_key, diff_value)
          | _ ->
              None)
        (fun ((), big_map, diff_key_hash, diff_key, diff_value) ->
          Update {big_map; diff_key_hash; diff_key; diff_value});
      case
        (Tag 1)
        ~title:"remove"
        (obj2 (req "action" (constant "remove")) (req "big_map" z))
        (function Clear big_map -> Some ((), big_map) | _ -> None)
        (fun ((), big_map) -> Clear big_map);
      case
        (Tag 2)
        ~title:"copy"
        (obj3
           (req "action" (constant "copy"))
           (req "source_big_map" z)
           (req "destination_big_map" z))
        (function Copy (src, dst) -> Some ((), src, dst) | _ -> None)
        (fun ((), src, dst) -> Copy (src, dst));
      case
        (Tag 3)
        ~title:"alloc"
        (obj4
           (req "action" (constant "alloc"))
           (req "big_map" z)
           (req "key_type" Script_repr.expr_encoding)
           (req "value_type" Script_repr.expr_encoding))
        (function
          | Alloc {big_map; key_type; value_type} ->
              Some ((), big_map, key_type, value_type)
          | _ ->
              None)
        (fun ((), big_map, key_type, value_type) ->
          Alloc {big_map; key_type; value_type}) ]

let big_map_diff_encoding =
  let open Data_encoding in
  def "contract.big_map_diff" @@ list big_map_diff_item_encoding

let big_map_key_cost = 65

let big_map_cost = 33

let update_script_big_map c = function
  | None ->
      return (c, Z.zero)
  | Some diff ->
      fold_left_s
        (fun (c, total) -> function Clear id ->
              Storage.Big_map.Total_bytes.get c id
              >>=? fun size ->
              Storage.Big_map.remove_rec c id
              >>= fun c ->
              if Compare.Z.(id < Z.zero) then return (c, total)
              else return (c, Z.sub (Z.sub total size) (Z.of_int big_map_cost))
          | Copy (from, to_) ->
              Storage.Big_map.copy c ~from ~to_
              >>=? fun c ->
              if Compare.Z.(to_ < Z.zero) then return (c, total)
              else
                Storage.Big_map.Total_bytes.get c from
                >>=? fun size ->
                return (c, Z.add (Z.add total size) (Z.of_int big_map_cost))
          | Alloc {big_map; key_type; value_type} ->
              Storage.Big_map.Total_bytes.init c big_map Z.zero
              >>=? fun c ->
              (* Annotations are erased to allow sharing on
                 [Copy]. The types from the contract code are used,
                 these ones are only used to make sure they are
                 compatible during transmissions between contracts,
                 and only need to be compatible, annotations
                 nonwhistanding. *)
              let key_type =
                Micheline.strip_locations
                  (Script_repr.strip_annotations (Micheline.root key_type))
              in
              let value_type =
                Micheline.strip_locations
                  (Script_repr.strip_annotations (Micheline.root value_type))
              in
              Storage.Big_map.Key_type.init c big_map key_type
              >>=? fun c ->
              Storage.Big_map.Value_type.init c big_map value_type
              >>=? fun c ->
              if Compare.Z.(big_map < Z.zero) then return (c, total)
              else return (c, Z.add total (Z.of_int big_map_cost))
          | Update {big_map; diff_key_hash; diff_value = None} ->
              Storage.Big_map.Contents.remove (c, big_map) diff_key_hash
              >>=? fun (c, freed, existed) ->
              let freed =
                if existed then freed + big_map_key_cost else freed
              in
              Storage.Big_map.Total_bytes.get c big_map
              >>=? fun size ->
              Storage.Big_map.Total_bytes.set
                c
                big_map
                (Z.sub size (Z.of_int freed))
              >>=? fun c ->
              if Compare.Z.(big_map < Z.zero) then return (c, total)
              else return (c, Z.sub total (Z.of_int freed))
          | Update {big_map; diff_key_hash; diff_value = Some v} ->
              Storage.Big_map.Contents.init_set (c, big_map) diff_key_hash v
              >>=? fun (c, size_diff, existed) ->
              let size_diff =
                if existed then size_diff else size_diff + big_map_key_cost
              in
              Storage.Big_map.Total_bytes.get c big_map
              >>=? fun size ->
              Storage.Big_map.Total_bytes.set
                c
                big_map
                (Z.add size (Z.of_int size_diff))
              >>=? fun c ->
              if Compare.Z.(big_map < Z.zero) then return (c, total)
              else return (c, Z.add total (Z.of_int size_diff)))
        (c, Z.zero)
        diff

let create_base c ?(prepaid_bootstrap_storage = false)
    (* Free space for bootstrap contracts *)
    contract ~balance ~manager ~delegate ?script () =
  ( match Contract_repr.is_implicit contract with
  | None ->
      return c
  | Some _ ->
      Storage.Contract.Global_counter.get c
      >>=? fun counter -> Storage.Contract.Counter.init c contract counter )
  >>=? fun c ->
  Storage.Contract.Balance.init c contract balance
  >>=? fun c ->
  ( match manager with
  | Some manager ->
      Storage.Contract.Manager.init c contract (Manager_repr.Hash manager)
  | None ->
      return c )
  >>=? fun c ->
  ( match delegate with
  | None ->
      return c
  | Some delegate ->
      Delegate_storage.init c contract delegate )
  >>=? fun c ->
  match script with
  | Some ({Script_repr.code; storage}, big_map_diff) ->
      Storage.Contract.Code.init c contract code
      >>=? fun (c, code_size) ->
      Storage.Contract.Storage.init c contract storage
      >>=? fun (c, storage_size) ->
      update_script_big_map c big_map_diff
      >>=? fun (c, big_map_size) ->
      let total_size =
        Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) big_map_size
      in
      assert (Compare.Z.(total_size >= Z.zero)) ;
      let prepaid_bootstrap_storage =
        if prepaid_bootstrap_storage then total_size else Z.zero
      in
      Storage.Contract.Paid_storage_space.init
        c
        contract
        prepaid_bootstrap_storage
      >>=? fun c ->
      Storage.Contract.Used_storage_space.init c contract total_size
  | None ->
      return c

let originate c ?prepaid_bootstrap_storage contract ~balance ~script ~delegate
    =
  create_base
    c
    ?prepaid_bootstrap_storage
    contract
    ~balance
    ~manager:None
    ~delegate
    ~script
    ()

let create_implicit c manager ~balance =
  create_base
    c
    (Contract_repr.implicit_contract manager)
    ~balance
    ~manager:(Some manager)
    ?script:None
    ~delegate:None
    ()

let delete c contract =
  match Contract_repr.is_implicit contract with
  | None ->
      (* For non implicit contract Big_map should be cleared *)
      failwith "Non implicit contracts cannot be removed"
  | Some _ ->
      Delegate_storage.remove c contract
      >>=? fun c ->
      Storage.Contract.Balance.delete c contract
      >>=? fun c ->
      Storage.Contract.Manager.delete c contract
      >>=? fun c ->
      Storage.Contract.Counter.delete c contract
      >>=? fun c ->
      Storage.Contract.Code.remove c contract
      >>=? fun (c, _, _) ->
      Storage.Contract.Storage.remove c contract
      >>=? fun (c, _, _) ->
      Storage.Contract.Paid_storage_space.remove c contract
      >>= fun c ->
      Storage.Contract.Used_storage_space.remove c contract
      >>= fun c -> return c

let allocated c contract =
  Storage.Contract.Balance.get_option c contract
  >>=? function None -> return_false | Some _ -> return_true

let exists c contract =
  match Contract_repr.is_implicit contract with
  | Some _ ->
      return_true
  | None ->
      allocated c contract

let must_exist c contract =
  exists c contract
  >>=? function
  | true -> return_unit | false -> fail (Non_existing_contract contract)

let must_be_allocated c contract =
  allocated c contract
  >>=? function
  | true ->
      return_unit
  | false -> (
    match Contract_repr.is_implicit contract with
    | Some pkh ->
        fail (Empty_implicit_contract pkh)
    | None ->
        fail (Non_existing_contract contract) )

let list c = Storage.Contract.list c

let fresh_contract_from_current_nonce c =
  Lwt.return (Raw_context.increment_origination_nonce c)
  >>=? fun (c, nonce) -> return (c, Contract_repr.originated_contract nonce)

let originated_from_current_nonce ~since:ctxt_since ~until:ctxt_until =
  Lwt.return (Raw_context.origination_nonce ctxt_since)
  >>=? fun since ->
  Lwt.return (Raw_context.origination_nonce ctxt_until)
  >>=? fun until ->
  filter_map_s
    (fun contract ->
      exists ctxt_until contract
      >>=? function true -> return_some contract | false -> return_none)
    (Contract_repr.originated_contracts ~since ~until)

let check_counter_increment c manager counter =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Counter.get c contract
  >>=? fun contract_counter ->
  let expected = Z.succ contract_counter in
  if Compare.Z.(expected = counter) then return_unit
  else if Compare.Z.(expected > counter) then
    fail (Counter_in_the_past (contract, expected, counter))
  else fail (Counter_in_the_future (contract, expected, counter))

let increment_counter c manager =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Global_counter.get c
  >>=? fun global_counter ->
  Storage.Contract.Global_counter.set c (Z.succ global_counter)
  >>=? fun c ->
  Storage.Contract.Counter.get c contract
  >>=? fun contract_counter ->
  Storage.Contract.Counter.set c contract (Z.succ contract_counter)

let get_script_code c contract = Storage.Contract.Code.get_option c contract

let get_script c contract =
  Storage.Contract.Code.get_option c contract
  >>=? fun (c, code) ->
  Storage.Contract.Storage.get_option c contract
  >>=? fun (c, storage) ->
  match (code, storage) with
  | (None, None) ->
      return (c, None)
  | (Some code, Some storage) ->
      return (c, Some {Script_repr.code; storage})
  | (None, Some _) | (Some _, None) ->
      failwith "get_script"

let get_storage ctxt contract =
  Storage.Contract.Storage.get_option ctxt contract
  >>=? function
  | (ctxt, None) ->
      return (ctxt, None)
  | (ctxt, Some storage) ->
      Lwt.return (Script_repr.force_decode storage)
      >>=? fun (storage, cost) ->
      Lwt.return (Raw_context.consume_gas ctxt cost)
      >>=? fun ctxt -> return (ctxt, Some storage)

let get_counter c manager =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Counter.get_option c contract
  >>=? function
  | None -> (
    match Contract_repr.is_implicit contract with
    | Some _ ->
        Storage.Contract.Global_counter.get c
    | None ->
        failwith "get_counter" )
  | Some v ->
      return v

let get_manager_key c manager =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Manager.get_option c contract
  >>=? function
  | None ->
      failwith "get_manager_key"
  | Some (Manager_repr.Hash _) ->
      fail (Unrevealed_manager_key contract)
  | Some (Manager_repr.Public_key v) ->
      return v

let is_manager_key_revealed c manager =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Manager.get_option c contract
  >>=? function
  | None ->
      return_false
  | Some (Manager_repr.Hash _) ->
      return_false
  | Some (Manager_repr.Public_key _) ->
      return_true

let reveal_manager_key c manager public_key =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Manager.get c contract
  >>=? function
  | Public_key _ ->
      fail (Previously_revealed_key contract)
  | Hash v ->
      let actual_hash = Signature.Public_key.hash public_key in
      if Signature.Public_key_hash.equal actual_hash v then
        let v = Manager_repr.Public_key public_key in
        Storage.Contract.Manager.set c contract v >>=? fun c -> return c
      else fail (Inconsistent_hash (public_key, v, actual_hash))

let get_balance c contract =
  Storage.Contract.Balance.get_option c contract
  >>=? function
  | None -> (
    match Contract_repr.is_implicit contract with
    | Some _ ->
        return Tez_repr.zero
    | None ->
        failwith "get_balance" )
  | Some v ->
      return v

let update_script_storage c contract storage big_map_diff =
  let storage = Script_repr.lazy_expr storage in
  update_script_big_map c big_map_diff
  >>=? fun (c, big_map_size_diff) ->
  Storage.Contract.Storage.set c contract storage
  >>=? fun (c, size_diff) ->
  Storage.Contract.Used_storage_space.get c contract
  >>=? fun previous_size ->
  let new_size =
    Z.add previous_size (Z.add big_map_size_diff (Z.of_int size_diff))
  in
  Storage.Contract.Used_storage_space.set c contract new_size

let spend c contract amount =
  Storage.Contract.Balance.get c contract
  >>=? fun balance ->
  match Tez_repr.(balance -? amount) with
  | Error _ ->
      fail (Balance_too_low (contract, balance, amount))
  | Ok new_balance -> (
      Storage.Contract.Balance.set c contract new_balance
      >>=? fun c ->
      Roll_storage.Contract.remove_amount c contract amount
      >>=? fun c ->
      if Tez_repr.(new_balance > Tez_repr.zero) then return c
      else
        match Contract_repr.is_implicit contract with
        | None ->
            return c (* Never delete originated contracts *)
        | Some pkh -> (
            Delegate_storage.get c contract
            >>=? function
            | Some pkh' ->
                (* Don't delete "delegate" contract *)
                assert (Signature.Public_key_hash.equal pkh pkh') ;
                return c
            | None ->
                (* Delete empty implicit contract *)
                delete c contract ) )

let credit c contract amount =
  ( if Tez_repr.(amount <> Tez_repr.zero) then return c
  else
    Storage.Contract.Code.mem c contract
    >>=? fun (c, target_has_code) ->
    fail_unless target_has_code (Empty_transaction contract)
    >>=? fun () -> return c )
  >>=? fun c ->
  Storage.Contract.Balance.get_option c contract
  >>=? function
  | None -> (
    match Contract_repr.is_implicit contract with
    | None ->
        fail (Non_existing_contract contract)
    | Some manager ->
        create_implicit c manager ~balance:amount )
  | Some balance ->
      Lwt.return Tez_repr.(amount +? balance)
      >>=? fun balance ->
      Storage.Contract.Balance.set c contract balance
      >>=? fun c -> Roll_storage.Contract.add_amount c contract amount

let init c = Storage.Contract.Global_counter.init c Z.zero

let used_storage_space c contract =
  Storage.Contract.Used_storage_space.get_option c contract
  >>=? function None -> return Z.zero | Some fees -> return fees

let paid_storage_space c contract =
  Storage.Contract.Paid_storage_space.get_option c contract
  >>=? function None -> return Z.zero | Some paid_space -> return paid_space

let set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space
    =
  Storage.Contract.Paid_storage_space.get c contract
  >>=? fun already_paid_space ->
  if Compare.Z.(already_paid_space >= new_storage_space) then return (Z.zero, c)
  else
    let to_pay = Z.sub new_storage_space already_paid_space in
    Storage.Contract.Paid_storage_space.set c contract new_storage_space
    >>=? fun c -> return (to_pay, c)
Contract_storage.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Contract_repr.
Require Tezos.Delegate_storage.
Require Tezos.Manager_repr.
Require Tezos.Raw_context.
Require Tezos.Roll_storage.
Require Tezos.Script_expr_hash.
Require Tezos.Script_repr.
Require Tezos.Storage.
Require Tezos.Tez_repr.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition failwith {A : Set} (msg : string) : Lwt.t (Error_monad.tzresult A) :=
  Error_monad.fail extensible_type_value.

Module big_map_diff_item.
  Module Update.
    Record record {big_map diff_key diff_key_hash diff_value : Set} := {
      big_map : big_map;
      diff_key : diff_key;
      diff_key_hash : diff_key_hash;
      diff_value : diff_value }.
    Arguments record : clear implicits.
  End Update.
  Definition Update_skeleton := Update.record.
  
  Module Alloc.
    Record record {big_map key_type value_type : Set} := {
      big_map : big_map;
      key_type : key_type;
      value_type : value_type }.
    Arguments record : clear implicits.
  End Alloc.
  Definition Alloc_skeleton := Alloc.record.
End big_map_diff_item.

Reserved Notation "'big_map_diff_item.Update".
Reserved Notation "'big_map_diff_item.Alloc".

Inductive big_map_diff_item : Set :=
| Update : 'big_map_diff_item.Update -> big_map_diff_item
| Clear : Z.t -> big_map_diff_item
| Copy : Z.t -> Z.t -> big_map_diff_item
| Alloc : 'big_map_diff_item.Alloc -> big_map_diff_item

where "'big_map_diff_item.Update" :=
  (big_map_diff_item.Update_skeleton Z.t Script_repr.expr Script_expr_hash.t
    (option Script_repr.expr))
and "'big_map_diff_item.Alloc" :=
  (big_map_diff_item.Alloc_skeleton Z.t Script_repr.expr Script_repr.expr).

Module ConstructorRecordNotations_big_map_diff_item.
  Module big_map_diff_item.
    Definition Update := 'big_map_diff_item.Update.
    Definition Alloc := 'big_map_diff_item.Alloc.
  End big_map_diff_item.
End ConstructorRecordNotations_big_map_diff_item.
Import ConstructorRecordNotations_big_map_diff_item.

Definition big_map_diff := list big_map_diff_item.

Definition big_map_diff_item_encoding
  : Data_encoding.encoding big_map_diff_item :=
  Data_encoding.union None
    [
      Data_encoding.__case_value "update" None (Data_encoding.Tag 0)
        (Data_encoding.obj5
          (Data_encoding.req None None "action"
            (Data_encoding.constant "update"))
          (Data_encoding.req None None "big_map" Data_encoding.z)
          (Data_encoding.req None None "key_hash" Script_expr_hash.encoding)
          (Data_encoding.req None None "key" Script_repr.expr_encoding)
          (Data_encoding.opt None None "value" Script_repr.expr_encoding))
        (fun function_parameter =>
          match function_parameter with
          |
            Update {|
              big_map_diff_item.Update.big_map := big_map;
                big_map_diff_item.Update.diff_key := diff_key;
                big_map_diff_item.Update.diff_key_hash :=
                  diff_key_hash;
                big_map_diff_item.Update.diff_value := diff_value
                |} =>
            Some (tt, big_map, diff_key_hash, diff_key, diff_value)
          | _ => None
          end)
        (fun function_parameter =>
          let '(_, big_map, diff_key_hash, diff_key, diff_value) :=
            function_parameter in
          Update
            {| big_map_diff_item.Update.big_map := big_map;
              big_map_diff_item.Update.diff_key := diff_key;
              big_map_diff_item.Update.diff_key_hash := diff_key_hash;
              big_map_diff_item.Update.diff_value := diff_value |});
      Data_encoding.__case_value "remove" None (Data_encoding.Tag 1)
        (Data_encoding.obj2
          (Data_encoding.req None None "action"
            (Data_encoding.constant "remove"))
          (Data_encoding.req None None "big_map" Data_encoding.z))
        (fun function_parameter =>
          match function_parameter with
          | Clear big_map => Some (tt, big_map)
          | _ => None
          end)
        (fun function_parameter =>
          let '(_, big_map) := function_parameter in
          Clear big_map);
      Data_encoding.__case_value "copy" None (Data_encoding.Tag 2)
        (Data_encoding.obj3
          (Data_encoding.req None None "action"
            (Data_encoding.constant "copy"))
          (Data_encoding.req None None "source_big_map" Data_encoding.z)
          (Data_encoding.req None None "destination_big_map" Data_encoding.z))
        (fun function_parameter =>
          match function_parameter with
          | Copy src dst => Some (tt, src, dst)
          | _ => None
          end)
        (fun function_parameter =>
          let '(_, src, dst) := function_parameter in
          Copy src dst);
      Data_encoding.__case_value "alloc" None (Data_encoding.Tag 3)
        (Data_encoding.obj4
          (Data_encoding.req None None "action"
            (Data_encoding.constant "alloc"))
          (Data_encoding.req None None "big_map" Data_encoding.z)
          (Data_encoding.req None None "key_type" Script_repr.expr_encoding)
          (Data_encoding.req None None "value_type"
            Script_repr.expr_encoding))
        (fun function_parameter =>
          match function_parameter with
          |
            Alloc {|
              big_map_diff_item.Alloc.big_map := big_map;
                big_map_diff_item.Alloc.key_type := key_type;
                big_map_diff_item.Alloc.value_type := value_type
                |} => Some (tt, big_map, key_type, value_type)
          | _ => None
          end)
        (fun function_parameter =>
          let '(_, big_map, key_type, value_type) := function_parameter in
          Alloc
            {| big_map_diff_item.Alloc.big_map := big_map;
              big_map_diff_item.Alloc.key_type := key_type;
              big_map_diff_item.Alloc.value_type := value_type |})
    ].

Definition big_map_diff_encoding
  : Data_encoding.encoding (list big_map_diff_item) :=
  Pervasives.op_atat
    (let arg := Data_encoding.def "contract.big_map_diff" in
    fun eta => arg None None eta)
    (Data_encoding.__list_value None big_map_diff_item_encoding).

Definition big_map_key_cost : Z := 65.

Definition big_map_cost : Z := 33.

Definition update_script_big_map
  (c : Storage.Big_map.Total_bytes.context)
  (function_parameter : option (list big_map_diff_item))
  : Lwt.t (Error_monad.tzresult (Storage.Big_map.Total_bytes.context * Z.t)) :=
  match function_parameter with
  | None => Error_monad.__return (c, Z.zero)
  | Some diff =>
    Error_monad.fold_left_s
      (fun function_parameter =>
        let '(c, total) := function_parameter in
        fun function_parameter =>
          match function_parameter with
          | Clear id =>
            Error_monad.op_gtgteqquestion (Storage.Big_map.Total_bytes.get c id)
              (fun size =>
                Error_monad.op_gtgteq (Storage.Big_map.remove_rec c id)
                  (fun c =>
                    if (|Compare.Z|).(Compare.S.op_lt) id Z.zero then
                      Error_monad.__return (c, total)
                    else
                      Error_monad.__return
                        (c, (Z.sub (Z.sub total size) (Z.of_int big_map_cost)))))
          | Copy from to_ =>
            Error_monad.op_gtgteqquestion (Storage.Big_map.copy c from to_)
              (fun c =>
                if (|Compare.Z|).(Compare.S.op_lt) to_ Z.zero then
                  Error_monad.__return (c, total)
                else
                  Error_monad.op_gtgteqquestion
                    (Storage.Big_map.Total_bytes.get c from)
                    (fun size =>
                      Error_monad.__return
                        (c, (Z.add (Z.add total size) (Z.of_int big_map_cost)))))
          |
            Alloc {|
              big_map_diff_item.Alloc.big_map := big_map;
                big_map_diff_item.Alloc.key_type := key_type;
                big_map_diff_item.Alloc.value_type := value_type
                |} =>
            Error_monad.op_gtgteqquestion
              (Storage.Big_map.Total_bytes.init c big_map Z.zero)
              (fun c =>
                let key_type :=
                  Micheline.strip_locations
                    (Script_repr.strip_annotations (Micheline.root key_type)) in
                let value_type :=
                  Micheline.strip_locations
                    (Script_repr.strip_annotations (Micheline.root value_type))
                  in
                Error_monad.op_gtgteqquestion
                  (Storage.Big_map.Key_type.init c big_map key_type)
                  (fun c =>
                    Error_monad.op_gtgteqquestion
                      (Storage.Big_map.Value_type.init c big_map value_type)
                      (fun c =>
                        if (|Compare.Z|).(Compare.S.op_lt) big_map Z.zero then
                          Error_monad.__return (c, total)
                        else
                          Error_monad.__return
                            (c, (Z.add total (Z.of_int big_map_cost))))))
          |
            Update {|
              big_map_diff_item.Update.big_map := big_map;
                big_map_diff_item.Update.diff_key_hash := diff_key_hash;
                big_map_diff_item.Update.diff_value := None
                |} =>
            Error_monad.op_gtgteqquestion
              (Storage.Big_map.Contents.remove (c, big_map) diff_key_hash)
              (fun function_parameter =>
                let '(c, freed, existed) := function_parameter in
                let freed :=
                  if existed then
                    Pervasives.op_plus freed big_map_key_cost
                  else
                    freed in
                Error_monad.op_gtgteqquestion
                  (Storage.Big_map.Total_bytes.get c big_map)
                  (fun size =>
                    Error_monad.op_gtgteqquestion
                      (Storage.Big_map.Total_bytes.set c big_map
                        (Z.sub size (Z.of_int freed)))
                      (fun c =>
                        if (|Compare.Z|).(Compare.S.op_lt) big_map Z.zero then
                          Error_monad.__return (c, total)
                        else
                          Error_monad.__return
                            (c, (Z.sub total (Z.of_int freed))))))
          |
            Update {|
              big_map_diff_item.Update.big_map := big_map;
                big_map_diff_item.Update.diff_key_hash := diff_key_hash;
                big_map_diff_item.Update.diff_value := Some v
                |} =>
            Error_monad.op_gtgteqquestion
              (Storage.Big_map.Contents.init_set (c, big_map) diff_key_hash v)
              (fun function_parameter =>
                let '(c, size_diff, existed) := function_parameter in
                let size_diff :=
                  if existed then
                    size_diff
                  else
                    Pervasives.op_plus size_diff big_map_key_cost in
                Error_monad.op_gtgteqquestion
                  (Storage.Big_map.Total_bytes.get c big_map)
                  (fun size =>
                    Error_monad.op_gtgteqquestion
                      (Storage.Big_map.Total_bytes.set c big_map
                        (Z.add size (Z.of_int size_diff)))
                      (fun c =>
                        if (|Compare.Z|).(Compare.S.op_lt) big_map Z.zero then
                          Error_monad.__return (c, total)
                        else
                          Error_monad.__return
                            (c, (Z.add total (Z.of_int size_diff))))))
          end) (c, Z.zero) diff
  end.

Definition create_base (c : Raw_context.t) (op_staroptstar : option bool)
  : Contract_repr.contract -> Storage.Contract.Balance.value ->
  option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  option (Script_repr.t * option (list big_map_diff_item)) -> unit ->
  Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let prepaid_bootstrap_storage :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun contract =>
    fun balance =>
      fun manager =>
        fun delegate =>
          fun script =>
            fun function_parameter =>
              let '_ := function_parameter in
              Error_monad.op_gtgteqquestion
                match Contract_repr.is_implicit contract with
                | None => Error_monad.__return c
                | Some _ =>
                  Error_monad.op_gtgteqquestion
                    (Storage.Contract.Global_counter.get c)
                    (fun counter =>
                      Storage.Contract.Counter.init c contract counter)
                end
                (fun c =>
                  Error_monad.op_gtgteqquestion
                    (Storage.Contract.Balance.init c contract balance)
                    (fun c =>
                      Error_monad.op_gtgteqquestion
                        match manager with
                        | Some manager =>
                          Storage.Contract.Manager.init c contract
                            (Manager_repr.Hash manager)
                        | None => Error_monad.__return c
                        end
                        (fun c =>
                          Error_monad.op_gtgteqquestion
                            match delegate with
                            | None => Error_monad.__return c
                            | Some delegate =>
                              Delegate_storage.init c contract delegate
                            end
                            (fun c =>
                              match script with
                              |
                                Some
                                  ({|
                                    Script_repr.t.code := code;
                                      Script_repr.t.storage := storage
                                      |}, big_map_diff) =>
                                Error_monad.op_gtgteqquestion
                                  (Storage.Contract.Code.init c contract code)
                                  (fun function_parameter =>
                                    let '(c, code_size) := function_parameter in
                                    Error_monad.op_gtgteqquestion
                                      (Storage.Contract.Storage.init c contract
                                        storage)
                                      (fun function_parameter =>
                                        let '(c, storage_size) :=
                                          function_parameter in
                                        Error_monad.op_gtgteqquestion
                                          (update_script_big_map c big_map_diff)
                                          (fun function_parameter =>
                                            let '(c, big_map_size) :=
                                              function_parameter in
                                            let total_size :=
                                              Z.add
                                                (Z.add (Z.of_int code_size)
                                                  (Z.of_int storage_size))
                                                big_map_size in
                                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                                            (* ❌ instruction_sequence ";" *)
                                            let prepaid_bootstrap_storage :=
                                              if prepaid_bootstrap_storage then
                                                total_size
                                              else
                                                Z.zero in
                                            Error_monad.op_gtgteqquestion
                                              (Storage.Contract.Paid_storage_space.init
                                                c contract
                                                prepaid_bootstrap_storage)
                                              (fun c =>
                                                Storage.Contract.Used_storage_space.init
                                                  c contract total_size))))
                              | None => Error_monad.__return c
                              end)))).

Definition originate
  (c : Raw_context.t) (prepaid_bootstrap_storage : option bool)
  (contract : Contract_repr.contract) (balance : Storage.Contract.Balance.value)
  (script : Script_repr.t * option (list big_map_diff_item))
  (delegate : option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  create_base c prepaid_bootstrap_storage contract balance None delegate
    (Some script) tt.

Definition create_implicit
  (c : Raw_context.t)
  (manager : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (balance : Storage.Contract.Balance.value)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  create_base c None (Contract_repr.implicit_contract manager) balance
    (Some manager) None None tt.

Definition delete (c : Raw_context.t) (contract : Contract_repr.contract)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  match Contract_repr.is_implicit contract with
  | None => failwith "Non implicit contracts cannot be removed"
  | Some _ =>
    Error_monad.op_gtgteqquestion (Delegate_storage.remove c contract)
      (fun c =>
        Error_monad.op_gtgteqquestion
          (Storage.Contract.Balance.delete c contract)
          (fun c =>
            Error_monad.op_gtgteqquestion
              (Storage.Contract.Manager.delete c contract)
              (fun c =>
                Error_monad.op_gtgteqquestion
                  (Storage.Contract.Counter.delete c contract)
                  (fun c =>
                    Error_monad.op_gtgteqquestion
                      (Storage.Contract.Code.remove c contract)
                      (fun function_parameter =>
                        let '(c, _, _) := function_parameter in
                        Error_monad.op_gtgteqquestion
                          (Storage.Contract.Storage.remove c contract)
                          (fun function_parameter =>
                            let '(c, _, _) := function_parameter in
                            Error_monad.op_gtgteq
                              (Storage.Contract.Paid_storage_space.remove c
                                contract)
                              (fun c =>
                                Error_monad.op_gtgteq
                                  (Storage.Contract.Used_storage_space.remove c
                                    contract) (fun c => Error_monad.__return c))))))))
  end.

Definition allocated
  (c : Storage.Contract.Balance.context)
  (contract : Storage.Contract.Balance.key)
  : Lwt.t (Error_monad.tzresult bool) :=
  Error_monad.op_gtgteqquestion (Storage.Contract.Balance.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None => Error_monad.return_false
      | Some _ => Error_monad.return_true
      end).

Definition __exists
  (c : Storage.Contract.Balance.context) (contract : Contract_repr.contract)
  : Lwt.t (Error_monad.tzresult bool) :=
  match Contract_repr.is_implicit contract with
  | Some _ => Error_monad.return_true
  | None => allocated c contract
  end.

Definition must_exist
  (c : Storage.Contract.Balance.context) (contract : Contract_repr.contract)
  : Lwt.t (Error_monad.tzresult unit) :=
  Error_monad.op_gtgteqquestion (__exists c contract)
    (fun function_parameter =>
      match function_parameter with
      | true => Error_monad.return_unit
      | false => Error_monad.fail extensible_type_value
      end).

Definition must_be_allocated
  (c : Storage.Contract.Balance.context)
  (contract : Storage.Contract.Balance.key)
  : Lwt.t (Error_monad.tzresult unit) :=
  Error_monad.op_gtgteqquestion (allocated c contract)
    (fun function_parameter =>
      match function_parameter with
      | true => Error_monad.return_unit
      | false =>
        match Contract_repr.is_implicit contract with
        | Some pkh => Error_monad.fail extensible_type_value
        | None => Error_monad.fail extensible_type_value
        end
      end).

Definition __list_value (c : Raw_context.t) : Lwt.t (list Contract_repr.t) :=
  Storage.Contract.__list_value c.

Definition fresh_contract_from_current_nonce (c : Raw_context.t)
  : Lwt.t (Error_monad.tzresult (Raw_context.t * Contract_repr.contract)) :=
  Error_monad.op_gtgteqquestion
    (Lwt.__return (Raw_context.increment_origination_nonce c))
    (fun function_parameter =>
      let '(c, __nonce_value) := function_parameter in
      Error_monad.__return
        (c, (Contract_repr.originated_contract __nonce_value))).

Definition originated_from_current_nonce
  (ctxt_since : Raw_context.t) (ctxt_until : Raw_context.t)
  : Lwt.t (Error_monad.tzresult (list Contract_repr.contract)) :=
  Error_monad.op_gtgteqquestion
    (Lwt.__return (Raw_context.origination_nonce ctxt_since))
    (fun since =>
      Error_monad.op_gtgteqquestion
        (Lwt.__return (Raw_context.origination_nonce ctxt_until))
        (fun until =>
          Error_monad.filter_map_s
            (fun contract =>
              Error_monad.op_gtgteqquestion (__exists ctxt_until contract)
                (fun function_parameter =>
                  match function_parameter with
                  | true => Error_monad.return_some contract
                  | false => Error_monad.return_none
                  end)) (Contract_repr.originated_contracts since until))).

Definition check_counter_increment
  (c : Storage.Contract.Counter.context)
  (manager : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (counter : (|Compare.Z|).(Compare.S.t)) : Lwt.t (Error_monad.tzresult unit) :=
  let contract := Contract_repr.implicit_contract manager in
  Error_monad.op_gtgteqquestion (Storage.Contract.Counter.get c contract)
    (fun contract_counter =>
      let expected := Z.succ contract_counter in
      if (|Compare.Z|).(Compare.S.op_eq) expected counter then
        Error_monad.return_unit
      else
        if (|Compare.Z|).(Compare.S.op_gt) expected counter then
          Error_monad.fail extensible_type_value
        else
          Error_monad.fail extensible_type_value).

Definition increment_counter
  (c : Raw_context.t)
  (manager : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let contract := Contract_repr.implicit_contract manager in
  Error_monad.op_gtgteqquestion (Storage.Contract.Global_counter.get c)
    (fun global_counter =>
      Error_monad.op_gtgteqquestion
        (Storage.Contract.Global_counter.set c (Z.succ global_counter))
        (fun c =>
          Error_monad.op_gtgteqquestion
            (Storage.Contract.Counter.get c contract)
            (fun contract_counter =>
              Storage.Contract.Counter.set c contract (Z.succ contract_counter)))).

Definition get_script_code
  (c : Storage.Contract.Code.context) (contract : Storage.Contract.Code.key)
  : Lwt.t
    (Error_monad.tzresult (Raw_context.t * option Storage.Contract.Code.value)) :=
  Storage.Contract.Code.get_option c contract.

Definition get_script
  (c : Storage.Contract.Code.context) (contract : Storage.Contract.Code.key)
  : Lwt.t (Error_monad.tzresult (Raw_context.t * option Script_repr.t)) :=
  Error_monad.op_gtgteqquestion (Storage.Contract.Code.get_option c contract)
    (fun function_parameter =>
      let '(c, code) := function_parameter in
      Error_monad.op_gtgteqquestion
        (Storage.Contract.Storage.get_option c contract)
        (fun function_parameter =>
          let '(c, storage) := function_parameter in
          match (code, storage) with
          | (None, None) => Error_monad.__return (c, None)
          | (Some code, Some storage) =>
            Error_monad.__return
              (c,
                (Some
                  {| Script_repr.t.code := code;
                    Script_repr.t.storage := storage |}))
          | (None, Some _) | (Some _, None) => failwith "get_script"
          end)).

Definition get_storage
  (ctxt : Storage.Contract.Storage.context)
  (contract : Storage.Contract.Storage.key)
  : Lwt.t (Error_monad.tzresult (Raw_context.t * option Script_repr.expr)) :=
  Error_monad.op_gtgteqquestion
    (Storage.Contract.Storage.get_option ctxt contract)
    (fun function_parameter =>
      match function_parameter with
      | (ctxt, None) => Error_monad.__return (ctxt, None)
      | (ctxt, Some storage) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Script_repr.force_decode storage))
          (fun function_parameter =>
            let '(storage, cost) := function_parameter in
            Error_monad.op_gtgteqquestion
              (Lwt.__return (Raw_context.consume_gas ctxt cost))
              (fun ctxt => Error_monad.__return (ctxt, (Some storage))))
      end).

Definition get_counter
  (c : Storage.Contract.Counter.context)
  (manager : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.tzresult Z.t) :=
  let contract := Contract_repr.implicit_contract manager in
  Error_monad.op_gtgteqquestion (Storage.Contract.Counter.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        match Contract_repr.is_implicit contract with
        | Some _ => Storage.Contract.Global_counter.get c
        | None => failwith "get_counter"
        end
      | Some v => Error_monad.__return v
      end).

Definition get_manager_key
  (c : Storage.Contract.Manager.context)
  (manager : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.tzresult (|Signature.Public_key|).(S.SPublic_key.t)) :=
  let contract := Contract_repr.implicit_contract manager in
  Error_monad.op_gtgteqquestion (Storage.Contract.Manager.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None => failwith "get_manager_key"
      | Some (Manager_repr.Hash _) => Error_monad.fail extensible_type_value
      | Some (Manager_repr.Public_key v) => Error_monad.__return v
      end).

Definition is_manager_key_revealed
  (c : Storage.Contract.Manager.context)
  (manager : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.tzresult bool) :=
  let contract := Contract_repr.implicit_contract manager in
  Error_monad.op_gtgteqquestion (Storage.Contract.Manager.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None => Error_monad.return_false
      | Some (Manager_repr.Hash _) => Error_monad.return_false
      | Some (Manager_repr.Public_key _) => Error_monad.return_true
      end).

Definition reveal_manager_key
  (c : Storage.Contract.Manager.context)
  (manager : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (public_key : (|Signature.Public_key|).(S.SPublic_key.t))
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let contract := Contract_repr.implicit_contract manager in
  Error_monad.op_gtgteqquestion (Storage.Contract.Manager.get c contract)
    (fun function_parameter =>
      match function_parameter with
      | Manager_repr.Public_key _ => Error_monad.fail extensible_type_value
      | Manager_repr.Hash v =>
        let actual_hash :=
          (|Signature.Public_key|).(S.SPublic_key.__hash_value) public_key in
        if
          (|Signature.Public_key_hash|).(S.SPublic_key_hash.equal) actual_hash v
          then
          let v := Manager_repr.Public_key public_key in
          Error_monad.op_gtgteqquestion
            (Storage.Contract.Manager.set c contract v)
            (fun c => Error_monad.__return c)
        else
          Error_monad.fail extensible_type_value
      end).

Definition get_balance
  (c : Storage.Contract.Balance.context)
  (contract : Storage.Contract.Balance.key)
  : Lwt.t (Error_monad.tzresult Tez_repr.t) :=
  Error_monad.op_gtgteqquestion (Storage.Contract.Balance.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        match Contract_repr.is_implicit contract with
        | Some _ => Error_monad.__return Tez_repr.zero
        | None => failwith "get_balance"
        end
      | Some v => Error_monad.__return v
      end).

Definition update_script_storage
  (c : Storage.Big_map.Total_bytes.context)
  (contract : Storage.Contract.Storage.key) (storage : Script_repr.expr)
  (big_map_diff : option (list big_map_diff_item))
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let storage := Script_repr.__lazy_expr_value storage in
  Error_monad.op_gtgteqquestion (update_script_big_map c big_map_diff)
    (fun function_parameter =>
      let '(c, big_map_size_diff) := function_parameter in
      Error_monad.op_gtgteqquestion
        (Storage.Contract.Storage.set c contract storage)
        (fun function_parameter =>
          let '(c, size_diff) := function_parameter in
          Error_monad.op_gtgteqquestion
            (Storage.Contract.Used_storage_space.get c contract)
            (fun previous_size =>
              let new_size :=
                Z.add previous_size
                  (Z.add big_map_size_diff (Z.of_int size_diff)) in
              Storage.Contract.Used_storage_space.set c contract new_size))).

Definition spend
  (c : Storage.Contract.Balance.context)
  (contract : Storage.Contract.Balance.key) (amount : Tez_repr.t)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Error_monad.op_gtgteqquestion (Storage.Contract.Balance.get c contract)
    (fun balance =>
      match Tez_repr.op_minusquestion balance amount with
      | Pervasives.Error _ => Error_monad.fail extensible_type_value
      | Pervasives.Ok new_balance =>
        Error_monad.op_gtgteqquestion
          (Storage.Contract.Balance.set c contract new_balance)
          (fun c =>
            Error_monad.op_gtgteqquestion
              (Roll_storage.Contract.remove_amount c contract amount)
              (fun c =>
                if Tez_repr.op_gt new_balance Tez_repr.zero then
                  Error_monad.__return c
                else
                  match Contract_repr.is_implicit contract with
                  | None => Error_monad.__return c
                  | Some pkh =>
                    Error_monad.op_gtgteqquestion
                      (Delegate_storage.get c contract)
                      (fun function_parameter =>
                        match function_parameter with
                        | Some pkh' =>
                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                          (* ❌ instruction_sequence ";" *)
                          Error_monad.__return c
                        | None => delete c contract
                        end)
                  end))
      end).

Definition credit
  (c : Storage.Contract.Code.context) (contract : Storage.Contract.Code.key)
  (amount : Tez_repr.t) : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Error_monad.op_gtgteqquestion
    (if Tez_repr.op_ltgt amount Tez_repr.zero then
      Error_monad.__return c
    else
      Error_monad.op_gtgteqquestion (Storage.Contract.Code.mem c contract)
        (fun function_parameter =>
          let '(c, target_has_code) := function_parameter in
          Error_monad.op_gtgteqquestion
            (Error_monad.fail_unless target_has_code extensible_type_value)
            (fun function_parameter =>
              let '_ := function_parameter in
              Error_monad.__return c)))
    (fun c =>
      Error_monad.op_gtgteqquestion
        (Storage.Contract.Balance.get_option c contract)
        (fun function_parameter =>
          match function_parameter with
          | None =>
            match Contract_repr.is_implicit contract with
            | None => Error_monad.fail extensible_type_value
            | Some manager => create_implicit c manager amount
            end
          | Some balance =>
            Error_monad.op_gtgteqquestion
              (Lwt.__return (Tez_repr.op_plusquestion amount balance))
              (fun balance =>
                Error_monad.op_gtgteqquestion
                  (Storage.Contract.Balance.set c contract balance)
                  (fun c => Roll_storage.Contract.add_amount c contract amount))
          end)).

Definition init (c : Raw_context.t)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Storage.Contract.Global_counter.init c Z.zero.

Definition used_storage_space
  (c : Storage.Contract.Used_storage_space.context)
  (contract : Storage.Contract.Used_storage_space.key)
  : Lwt.t (Error_monad.tzresult Z.t) :=
  Error_monad.op_gtgteqquestion
    (Storage.Contract.Used_storage_space.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None => Error_monad.__return Z.zero
      | Some fees => Error_monad.__return fees
      end).

Definition paid_storage_space
  (c : Storage.Contract.Paid_storage_space.context)
  (contract : Storage.Contract.Paid_storage_space.key)
  : Lwt.t (Error_monad.tzresult Z.t) :=
  Error_monad.op_gtgteqquestion
    (Storage.Contract.Paid_storage_space.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None => Error_monad.__return Z.zero
      | Some paid_space => Error_monad.__return paid_space
      end).

Definition set_paid_storage_space_and_return_fees_to_pay
  (c : Storage.Contract.Paid_storage_space.context)
  (contract : Storage.Contract.Paid_storage_space.key)
  (new_storage_space : (|Compare.Z|).(Compare.S.t))
  : Lwt.t
    (Error_monad.tzresult (Z.t * Storage.Contract.Paid_storage_space.context)) :=
  Error_monad.op_gtgteqquestion
    (Storage.Contract.Paid_storage_space.get c contract)
    (fun already_paid_space =>
      if (|Compare.Z|).(Compare.S.op_gteq) already_paid_space new_storage_space
        then
        Error_monad.__return (Z.zero, c)
      else
        let to_pay := Z.sub new_storage_space already_paid_space in
        Error_monad.op_gtgteqquestion
          (Storage.Contract.Paid_storage_space.set c contract new_storage_space)
          (fun c => Error_monad.__return (to_pay, c))).

Contract_storage_mli

  • OCaml size: 169 lines
  • Coq size: 159 lines (-6% compared to OCaml)
contract_storage.mli 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error +=
  | Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t
  | (* `Temporary *)
      Counter_in_the_past of Contract_repr.contract * Z.t * Z.t
  | (* `Branch *)
      Counter_in_the_future of Contract_repr.contract * Z.t * Z.t
  | (* `Temporary *)
      Unspendable_contract of Contract_repr.contract
  | (* `Permanent *)
      Non_existing_contract of Contract_repr.contract
  | (* `Temporary *)
      Empty_implicit_contract of Signature.Public_key_hash.t
  | (* `Temporary *)
      Empty_transaction of Contract_repr.t (* `Temporary *)
  | Inconsistent_hash of
      Signature.Public_key.t
      * Signature.Public_key_hash.t
      * Signature.Public_key_hash.t
  | (* `Permanent *)
      Inconsistent_public_key of
      Signature.Public_key.t * Signature.Public_key.t
  | (* `Permanent *)
      Failure of string (* `Permanent *)
  | Previously_revealed_key of Contract_repr.t (* `Permanent *)
  | Unrevealed_manager_key of Contract_repr.t

(* `Permanent *)

val exists : Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t

val must_exist : Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t

val allocated : Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t

val must_be_allocated : Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t

val list : Raw_context.t -> Contract_repr.t list Lwt.t

val check_counter_increment :
  Raw_context.t -> Signature.Public_key_hash.t -> Z.t -> unit tzresult Lwt.t

val increment_counter :
  Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t

val get_manager_key :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Signature.Public_key.t tzresult Lwt.t

val is_manager_key_revealed :
  Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t

val reveal_manager_key :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Signature.Public_key.t ->
  Raw_context.t tzresult Lwt.t

val get_balance : Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t

val get_counter :
  Raw_context.t -> Signature.Public_key_hash.t -> Z.t tzresult Lwt.t

val get_script_code :
  Raw_context.t ->
  Contract_repr.t ->
  (Raw_context.t * Script_repr.lazy_expr option) tzresult Lwt.t

val get_script :
  Raw_context.t ->
  Contract_repr.t ->
  (Raw_context.t * Script_repr.t option) tzresult Lwt.t

val get_storage :
  Raw_context.t ->
  Contract_repr.t ->
  (Raw_context.t * Script_repr.expr option) tzresult Lwt.t

type big_map_diff_item =
  | Update of {
      big_map : Z.t;
      diff_key : Script_repr.expr;
      diff_key_hash : Script_expr_hash.t;
      diff_value : Script_repr.expr option;
    }
  | Clear of Z.t
  | Copy of Z.t * Z.t
  | Alloc of {
      big_map : Z.t;
      key_type : Script_repr.expr;
      value_type : Script_repr.expr;
    }

type big_map_diff = big_map_diff_item list

val big_map_diff_encoding : big_map_diff Data_encoding.t

val update_script_storage :
  Raw_context.t ->
  Contract_repr.t ->
  Script_repr.expr ->
  big_map_diff option ->
  Raw_context.t tzresult Lwt.t

val credit :
  Raw_context.t ->
  Contract_repr.t ->
  Tez_repr.t ->
  Raw_context.t tzresult Lwt.t

val spend :
  Raw_context.t ->
  Contract_repr.t ->
  Tez_repr.t ->
  Raw_context.t tzresult Lwt.t

val originate :
  Raw_context.t ->
  ?prepaid_bootstrap_storage:bool ->
  Contract_repr.t ->
  balance:Tez_repr.t ->
  script:Script_repr.t * big_map_diff option ->
  delegate:Signature.Public_key_hash.t option ->
  Raw_context.t tzresult Lwt.t

val fresh_contract_from_current_nonce :
  Raw_context.t -> (Raw_context.t * Contract_repr.t) tzresult Lwt.t

val originated_from_current_nonce :
  since:Raw_context.t ->
  until:Raw_context.t ->
  Contract_repr.t list tzresult Lwt.t

val init : Raw_context.t -> Raw_context.t tzresult Lwt.t

val used_storage_space : Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t

val paid_storage_space : Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t

val set_paid_storage_space_and_return_fees_to_pay :
  Raw_context.t ->
  Contract_repr.t ->
  Z.t ->
  (Z.t * Raw_context.t) tzresult Lwt.t
Contract_storage_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Contract_repr.
Require Tezos.Raw_context.
Require Tezos.Script_expr_hash.
Require Tezos.Script_repr.
Require Tezos.Tez_repr.

(* extensible_type error *)

Parameter __exists :
  Raw_context.t -> Contract_repr.t -> Lwt.t (Error_monad.tzresult bool).

Parameter must_exist :
  Raw_context.t -> Contract_repr.t -> Lwt.t (Error_monad.tzresult unit).

Parameter allocated :
  Raw_context.t -> Contract_repr.t -> Lwt.t (Error_monad.tzresult bool).

Parameter must_be_allocated :
  Raw_context.t -> Contract_repr.t -> Lwt.t (Error_monad.tzresult unit).

Parameter __list_value : Raw_context.t -> Lwt.t (list Contract_repr.t).

Parameter check_counter_increment :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Z.t -> Lwt.t (Error_monad.tzresult unit).

Parameter increment_counter :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter get_manager_key :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult (|Signature.Public_key|).(S.SPublic_key.t)).

Parameter is_manager_key_revealed :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult bool).

Parameter reveal_manager_key :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  (|Signature.Public_key|).(S.SPublic_key.t) ->
  Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter get_balance :
  Raw_context.t -> Contract_repr.t -> Lwt.t (Error_monad.tzresult Tez_repr.t).

Parameter get_counter :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult Z.t).

Parameter get_script_code :
  Raw_context.t -> Contract_repr.t ->
  Lwt.t (Error_monad.tzresult (Raw_context.t * option Script_repr.lazy_expr)).

Parameter get_script :
  Raw_context.t -> Contract_repr.t ->
  Lwt.t (Error_monad.tzresult (Raw_context.t * option Script_repr.t)).

Parameter get_storage :
  Raw_context.t -> Contract_repr.t ->
  Lwt.t (Error_monad.tzresult (Raw_context.t * option Script_repr.expr)).

Module big_map_diff_item.
  Module Update.
    Record record {big_map diff_key diff_key_hash diff_value : Set} := {
      big_map : big_map;
      diff_key : diff_key;
      diff_key_hash : diff_key_hash;
      diff_value : diff_value }.
    Arguments record : clear implicits.
  End Update.
  Definition Update_skeleton := Update.record.
  
  Module Alloc.
    Record record {big_map key_type value_type : Set} := {
      big_map : big_map;
      key_type : key_type;
      value_type : value_type }.
    Arguments record : clear implicits.
  End Alloc.
  Definition Alloc_skeleton := Alloc.record.
End big_map_diff_item.

Reserved Notation "'big_map_diff_item.Update".
Reserved Notation "'big_map_diff_item.Alloc".

Inductive big_map_diff_item : Set :=
| Update : 'big_map_diff_item.Update -> big_map_diff_item
| Clear : Z.t -> big_map_diff_item
| Copy : Z.t -> Z.t -> big_map_diff_item
| Alloc : 'big_map_diff_item.Alloc -> big_map_diff_item

where "'big_map_diff_item.Update" :=
  (big_map_diff_item.Update_skeleton Z.t Script_repr.expr Script_expr_hash.t
    (option Script_repr.expr))
and "'big_map_diff_item.Alloc" :=
  (big_map_diff_item.Alloc_skeleton Z.t Script_repr.expr Script_repr.expr).

Module ConstructorRecordNotations_big_map_diff_item.
  Module big_map_diff_item.
    Definition Update := 'big_map_diff_item.Update.
    Definition Alloc := 'big_map_diff_item.Alloc.
  End big_map_diff_item.
End ConstructorRecordNotations_big_map_diff_item.
Import ConstructorRecordNotations_big_map_diff_item.

Definition big_map_diff := list big_map_diff_item.

Parameter big_map_diff_encoding : Data_encoding.t big_map_diff.

Parameter update_script_storage :
  Raw_context.t -> Contract_repr.t -> Script_repr.expr -> option big_map_diff ->
  Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter credit :
  Raw_context.t -> Contract_repr.t -> Tez_repr.t ->
  Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter spend :
  Raw_context.t -> Contract_repr.t -> Tez_repr.t ->
  Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter originate :
  Raw_context.t -> option bool -> Contract_repr.t -> Tez_repr.t ->
  Script_repr.t * option big_map_diff ->
  option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter fresh_contract_from_current_nonce :
  Raw_context.t ->
  Lwt.t (Error_monad.tzresult (Raw_context.t * Contract_repr.t)).

Parameter originated_from_current_nonce :
  Raw_context.t -> Raw_context.t ->
  Lwt.t (Error_monad.tzresult (list Contract_repr.t)).

Parameter init : Raw_context.t -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter used_storage_space :
  Raw_context.t -> Contract_repr.t -> Lwt.t (Error_monad.tzresult Z.t).

Parameter paid_storage_space :
  Raw_context.t -> Contract_repr.t -> Lwt.t (Error_monad.tzresult Z.t).

Parameter set_paid_storage_space_and_return_fees_to_pay :
  Raw_context.t -> Contract_repr.t -> Z.t ->
  Lwt.t (Error_monad.tzresult (Z.t * Raw_context.t)).

Cycle_repr

  • OCaml size: 93 lines
  • Coq size: 127 lines (+36% compared to OCaml)
cycle_repr.ml 4 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = int32

type cycle = t

let encoding = Data_encoding.int32

let rpc_arg =
  let construct = Int32.to_string in
  let destruct str =
    match Int32.of_string str with
    | exception _ ->
        Error "Cannot parse cycle"
    | cycle ->
        Ok cycle
  in
  RPC_arg.make
    ~descr:"A cycle integer"
    ~name:"block_cycle"
    ~construct
    ~destruct
    ()

let pp ppf cycle = Format.fprintf ppf "%ld" cycle

include (Compare.Int32 : Compare.S with type t := t)

module Map = Map.Make (Compare.Int32)

let root = 0l

let succ = Int32.succ

let pred = function 0l -> None | i -> Some (Int32.pred i)

let add c i =
  assert (Compare.Int.(i > 0)) ;
  Int32.add c (Int32.of_int i)

let sub c i =
  assert (Compare.Int.(i > 0)) ;
  let r = Int32.sub c (Int32.of_int i) in
  if Compare.Int32.(r < 0l) then None else Some r

let to_int32 i = i

let of_int32_exn l =
  if Compare.Int32.(l >= 0l) then l
  else invalid_arg "Level_repr.Cycle.of_int32"

module Index = struct
  type t = cycle

  let path_length = 1

  let to_path c l = Int32.to_string (to_int32 c) :: l

  let of_path = function
    | [s] -> (
      try Some (Int32.of_string s) with _ -> None )
    | _ ->
        None

  let rpc_arg = rpc_arg

  let encoding = encoding

  let compare = compare
end
Cycle_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Definition t := int32.

Definition cycle := t.

Definition encoding : Data_encoding.encoding int32 :=
  Data_encoding.__int32_value.

Definition rpc_arg : RPC_arg.arg int32 :=
  let construct := Int32.to_string in
  let destruct (str : string) : Pervasives.result int32 string :=
    let 'cycle := Int32.of_string str in
    Pervasives.Ok cycle in
  RPC_arg.make (Some "A cycle integer") "block_cycle" destruct construct tt.

Definition pp (ppf : Format.formatter) (cycle : int32) : unit :=
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
        CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.No_precision
        CamlinternalFormatBasics.End_of_format) "%ld") cycle.

Definition op_eq := (|Compare.Int32|).(Compare.S.op_eq).

Definition op_ltgt := (|Compare.Int32|).(Compare.S.op_ltgt).

Definition op_lt := (|Compare.Int32|).(Compare.S.op_lt).

Definition op_lteq := (|Compare.Int32|).(Compare.S.op_lteq).

Definition op_gteq := (|Compare.Int32|).(Compare.S.op_gteq).

Definition op_gt := (|Compare.Int32|).(Compare.S.op_gt).

Definition compare := (|Compare.Int32|).(Compare.S.compare).

Definition equal := (|Compare.Int32|).(Compare.S.equal).

Definition max := (|Compare.Int32|).(Compare.S.max).

Definition min := (|Compare.Int32|).(Compare.S.min).

Definition Map :=
  Map.Make
    (existT _ _
      {|
        Compare.COMPARABLE.compare := (|Compare.Int32|).(Compare.S.compare)
      |}).

Definition root : int32 :=
  (* ❌ Constant of type int32 is converted to int *)
  0.

Definition succ : int32 -> int32 := Int32.succ.

Definition pred (function_parameter : int32) : option int32 :=
  match function_parameter with
  |
    (* ❌ Constant of type int32 is converted to int *)
    0 => None
  | i => Some (Int32.pred i)
  end.

Definition add (c : int32) (i : (|Compare.Int|).(Compare.S.t)) : int32 :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  Int32.add c (Int32.of_int i).

Definition sub (c : int32) (i : (|Compare.Int|).(Compare.S.t)) : option int32 :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  let r := Int32.sub c (Int32.of_int i) in
  if
    (|Compare.Int32|).(Compare.S.op_lt) r
      (* ❌ Constant of type int32 is converted to int *)
      0 then
    None
  else
    Some r.

Definition to_int32 {A : Set} (i : A) : A := i.

Definition of_int32_exn (l : (|Compare.Int32|).(Compare.S.t))
  : (|Compare.Int32|).(Compare.S.t) :=
  if
    (|Compare.Int32|).(Compare.S.op_gteq) l
      (* ❌ Constant of type int32 is converted to int *)
      0 then
    l
  else
    Pervasives.invalid_arg "Level_repr.Cycle.of_int32".

Module Index.
  Definition t := cycle.
  
  Definition path_length : Z := 1.
  
  Definition to_path (c : int32) (l : list string) : list string :=
    cons (Int32.to_string (to_int32 c)) l.
  
  Definition of_path (function_parameter : list string) : option int32 :=
    match function_parameter with
    | cons s [] =>
      (* ❌ Try-with are not handled *)
      try (Some (Int32.of_string s))
    | _ => None
    end.
  
  Definition rpc_arg : RPC_arg.arg int32 := rpc_arg.
  
  Definition encoding : Data_encoding.encoding int32 := encoding.
  
  Definition compare : t -> t -> Z := compare.
End Index.

Cycle_repr_mli

  • OCaml size: 54 lines
  • Coq size: 63 lines (+16% compared to OCaml)
cycle_repr.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t

type cycle = t

include Compare.S with type t := t

val encoding : cycle Data_encoding.t

val rpc_arg : cycle RPC_arg.arg

val pp : Format.formatter -> cycle -> unit

val root : cycle

val pred : cycle -> cycle option

val add : cycle -> int -> cycle

val sub : cycle -> int -> cycle option

val succ : cycle -> cycle

val to_int32 : cycle -> int32

val of_int32_exn : int32 -> cycle

module Map : S.MAP with type key = cycle

module Index : Storage_description.INDEX with type t = cycle
Cycle_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Storage_description.

Parameter t : Set.

Definition cycle := t.

Parameter Included_S : {_ : unit & Compare.S.signature t}.

Definition op_eq := (|Included_S|).(Compare.S.op_eq).

Definition op_ltgt := (|Included_S|).(Compare.S.op_ltgt).

Definition op_lt := (|Included_S|).(Compare.S.op_lt).

Definition op_lteq := (|Included_S|).(Compare.S.op_lteq).

Definition op_gteq := (|Included_S|).(Compare.S.op_gteq).

Definition op_gt := (|Included_S|).(Compare.S.op_gt).

Definition compare := (|Included_S|).(Compare.S.compare).

Definition equal := (|Included_S|).(Compare.S.equal).

Definition max := (|Included_S|).(Compare.S.max).

Definition min := (|Included_S|).(Compare.S.min).

Parameter encoding : Data_encoding.t cycle.

Parameter rpc_arg : RPC_arg.arg cycle.

Parameter pp : Format.formatter -> cycle -> unit.

Parameter root : cycle.

Parameter pred : cycle -> option cycle.

Parameter add : cycle -> Z -> cycle.

Parameter sub : cycle -> Z -> option cycle.

Parameter succ : cycle -> cycle.

Parameter to_int32 : cycle -> int32.

Parameter of_int32_exn : int32 -> cycle.

Parameter Map : {t : _ & S.MAP.signature cycle t}.

Parameter Index : {_ : unit & Storage_description.INDEX.signature cycle}.

Delegate_services

  • OCaml size: 697 lines
  • Coq size: 1352 lines (+93% compared to OCaml)
delegate_services.ml 224 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

type info = {
  balance : Tez.t;
  frozen_balance : Tez.t;
  frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t;
  staking_balance : Tez.t;
  delegated_contracts : Contract_repr.t list;
  delegated_balance : Tez.t;
  deactivated : bool;
  grace_period : Cycle.t;
}

let info_encoding =
  let open Data_encoding in
  conv
    (fun { balance;
           frozen_balance;
           frozen_balance_by_cycle;
           staking_balance;
           delegated_contracts;
           delegated_balance;
           deactivated;
           grace_period } ->
      ( balance,
        frozen_balance,
        frozen_balance_by_cycle,
        staking_balance,
        delegated_contracts,
        delegated_balance,
        deactivated,
        grace_period ))
    (fun ( balance,
           frozen_balance,
           frozen_balance_by_cycle,
           staking_balance,
           delegated_contracts,
           delegated_balance,
           deactivated,
           grace_period ) ->
      {
        balance;
        frozen_balance;
        frozen_balance_by_cycle;
        staking_balance;
        delegated_contracts;
        delegated_balance;
        deactivated;
        grace_period;
      })
    (obj8
       (req "balance" Tez.encoding)
       (req "frozen_balance" Tez.encoding)
       (req "frozen_balance_by_cycle" Delegate.frozen_balance_by_cycle_encoding)
       (req "staking_balance" Tez.encoding)
       (req "delegated_contracts" (list Contract_repr.encoding))
       (req "delegated_balance" Tez.encoding)
       (req "deactivated" bool)
       (req "grace_period" Cycle.encoding))

module S = struct
  let path = RPC_path.(open_root / "context" / "delegates")

  open Data_encoding

  type list_query = {active : bool; inactive : bool}

  let list_query : list_query RPC_query.t =
    let open RPC_query in
    query (fun active inactive -> {active; inactive})
    |+ flag "active" (fun t -> t.active)
    |+ flag "inactive" (fun t -> t.inactive)
    |> seal

  let list_delegate =
    RPC_service.get_service
      ~description:"Lists all registered delegates."
      ~query:list_query
      ~output:(list Signature.Public_key_hash.encoding)
      path

  let path = RPC_path.(path /: Signature.Public_key_hash.rpc_arg)

  let info =
    RPC_service.get_service
      ~description:"Everything about a delegate."
      ~query:RPC_query.empty
      ~output:info_encoding
      path

  let balance =
    RPC_service.get_service
      ~description:
        "Returns the full balance of a given delegate, including the frozen \
         balances."
      ~query:RPC_query.empty
      ~output:Tez.encoding
      RPC_path.(path / "balance")

  let frozen_balance =
    RPC_service.get_service
      ~description:
        "Returns the total frozen balances of a given delegate, this includes \
         the frozen deposits, rewards and fees."
      ~query:RPC_query.empty
      ~output:Tez.encoding
      RPC_path.(path / "frozen_balance")

  let frozen_balance_by_cycle =
    RPC_service.get_service
      ~description:
        "Returns the frozen balances of a given delegate, indexed by the \
         cycle by which it will be unfrozen"
      ~query:RPC_query.empty
      ~output:Delegate.frozen_balance_by_cycle_encoding
      RPC_path.(path / "frozen_balance_by_cycle")

  let staking_balance =
    RPC_service.get_service
      ~description:
        "Returns the total amount of tokens delegated to a given delegate. \
         This includes the balances of all the contracts that delegate to it, \
         but also the balance of the delegate itself and its frozen fees and \
         deposits. The rewards do not count in the delegated balance until \
         they are unfrozen."
      ~query:RPC_query.empty
      ~output:Tez.encoding
      RPC_path.(path / "staking_balance")

  let delegated_contracts =
    RPC_service.get_service
      ~description:
        "Returns the list of contracts that delegate to a given delegate."
      ~query:RPC_query.empty
      ~output:(list Contract_repr.encoding)
      RPC_path.(path / "delegated_contracts")

  let delegated_balance =
    RPC_service.get_service
      ~description:
        "Returns the balances of all the contracts that delegate to a given \
         delegate. This excludes the delegate's own balance and its frozen \
         balances."
      ~query:RPC_query.empty
      ~output:Tez.encoding
      RPC_path.(path / "delegated_balance")

  let deactivated =
    RPC_service.get_service
      ~description:
        "Tells whether the delegate is currently tagged as deactivated or not."
      ~query:RPC_query.empty
      ~output:bool
      RPC_path.(path / "deactivated")

  let grace_period =
    RPC_service.get_service
      ~description:
        "Returns the cycle by the end of which the delegate might be \
         deactivated if she fails to execute any delegate action. A \
         deactivated delegate might be reactivated (without loosing any \
         rolls) by simply re-registering as a delegate. For deactivated \
         delegates, this value contains the cycle by which they were \
         deactivated."
      ~query:RPC_query.empty
      ~output:Cycle.encoding
      RPC_path.(path / "grace_period")
end

let register () =
  let open Services_registration in
  register0 S.list_delegate (fun ctxt q () ->
      Delegate.list ctxt
      >>= fun delegates ->
      if q.active && q.inactive then return delegates
      else if q.active then
        filter_map_s
          (fun pkh ->
            Delegate.deactivated ctxt pkh
            >>=? function true -> return_none | false -> return_some pkh)
          delegates
      else if q.inactive then
        filter_map_s
          (fun pkh ->
            Delegate.deactivated ctxt pkh
            >>=? function false -> return_none | true -> return_some pkh)
          delegates
      else return_nil) ;
  register1 S.info (fun ctxt pkh () () ->
      Delegate.full_balance ctxt pkh
      >>=? fun balance ->
      Delegate.frozen_balance ctxt pkh
      >>=? fun frozen_balance ->
      Delegate.frozen_balance_by_cycle ctxt pkh
      >>= fun frozen_balance_by_cycle ->
      Delegate.staking_balance ctxt pkh
      >>=? fun staking_balance ->
      Delegate.delegated_contracts ctxt pkh
      >>= fun delegated_contracts ->
      Delegate.delegated_balance ctxt pkh
      >>=? fun delegated_balance ->
      Delegate.deactivated ctxt pkh
      >>=? fun deactivated ->
      Delegate.grace_period ctxt pkh
      >>=? fun grace_period ->
      return
        {
          balance;
          frozen_balance;
          frozen_balance_by_cycle;
          staking_balance;
          delegated_contracts;
          delegated_balance;
          deactivated;
          grace_period;
        }) ;
  register1 S.balance (fun ctxt pkh () () -> Delegate.full_balance ctxt pkh) ;
  register1 S.frozen_balance (fun ctxt pkh () () ->
      Delegate.frozen_balance ctxt pkh) ;
  register1 S.frozen_balance_by_cycle (fun ctxt pkh () () ->
      Delegate.frozen_balance_by_cycle ctxt pkh >>= return) ;
  register1 S.staking_balance (fun ctxt pkh () () ->
      Delegate.staking_balance ctxt pkh) ;
  register1 S.delegated_contracts (fun ctxt pkh () () ->
      Delegate.delegated_contracts ctxt pkh >>= return) ;
  register1 S.delegated_balance (fun ctxt pkh () () ->
      Delegate.delegated_balance ctxt pkh) ;
  register1 S.deactivated (fun ctxt pkh () () -> Delegate.deactivated ctxt pkh) ;
  register1 S.grace_period (fun ctxt pkh () () ->
      Delegate.grace_period ctxt pkh)

let list ctxt block ?(active = true) ?(inactive = false) () =
  RPC_context.make_call0 S.list_delegate ctxt block {active; inactive} ()

let info ctxt block pkh = RPC_context.make_call1 S.info ctxt block pkh () ()

let balance ctxt block pkh =
  RPC_context.make_call1 S.balance ctxt block pkh () ()

let frozen_balance ctxt block pkh =
  RPC_context.make_call1 S.frozen_balance ctxt block pkh () ()

let frozen_balance_by_cycle ctxt block pkh =
  RPC_context.make_call1 S.frozen_balance_by_cycle ctxt block pkh () ()

let staking_balance ctxt block pkh =
  RPC_context.make_call1 S.staking_balance ctxt block pkh () ()

let delegated_contracts ctxt block pkh =
  RPC_context.make_call1 S.delegated_contracts ctxt block pkh () ()

let delegated_balance ctxt block pkh =
  RPC_context.make_call1 S.delegated_balance ctxt block pkh () ()

let deactivated ctxt block pkh =
  RPC_context.make_call1 S.deactivated ctxt block pkh () ()

let grace_period ctxt block pkh =
  RPC_context.make_call1 S.grace_period ctxt block pkh () ()

let requested_levels ~default ctxt cycles levels =
  match (levels, cycles) with
  | ([], []) ->
      return [default]
  | (levels, cycles) ->
      (* explicitly fail when requested levels or cycle are in the past...
         or too far in the future... *)
      let levels =
        List.sort_uniq
          Level.compare
          (List.concat
             ( List.map (Level.from_raw ctxt) levels
             :: List.map (Level.levels_in_cycle ctxt) cycles ))
      in
      map_s
        (fun level ->
          let current_level = Level.current ctxt in
          if Level.(level <= current_level) then return (level, None)
          else
            Baking.earlier_predecessor_timestamp ctxt level
            >>=? fun timestamp -> return (level, Some timestamp))
        levels

module Baking_rights = struct
  type t = {
    level : Raw_level.t;
    delegate : Signature.Public_key_hash.t;
    priority : int;
    timestamp : Timestamp.t option;
  }

  let encoding =
    let open Data_encoding in
    conv
      (fun {level; delegate; priority; timestamp} ->
        (level, delegate, priority, timestamp))
      (fun (level, delegate, priority, timestamp) ->
        {level; delegate; priority; timestamp})
      (obj4
         (req "level" Raw_level.encoding)
         (req "delegate" Signature.Public_key_hash.encoding)
         (req "priority" uint16)
         (opt "estimated_time" Timestamp.encoding))

  module S = struct
    open Data_encoding

    let custom_root = RPC_path.(open_root / "helpers" / "baking_rights")

    type baking_rights_query = {
      levels : Raw_level.t list;
      cycles : Cycle.t list;
      delegates : Signature.Public_key_hash.t list;
      max_priority : int option;
      all : bool;
    }

    let baking_rights_query =
      let open RPC_query in
      query (fun levels cycles delegates max_priority all ->
          {levels; cycles; delegates; max_priority; all})
      |+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels)
      |+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles)
      |+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t ->
             t.delegates)
      |+ opt_field "max_priority" RPC_arg.int (fun t -> t.max_priority)
      |+ flag "all" (fun t -> t.all)
      |> seal

    let baking_rights =
      RPC_service.get_service
        ~description:
          "Retrieves the list of delegates allowed to bake a block.\n\
           By default, it gives the best baking priorities for bakers that \
           have at least one opportunity below the 64th priority for the next \
           block.\n\
           Parameters `level` and `cycle` can be used to specify the (valid) \
           level(s) in the past or future at which the baking rights have to \
           be returned. Parameter `delegate` can be used to restrict the \
           results to the given delegates. If parameter `all` is set, all the \
           baking opportunities for each baker at each level are returned, \
           instead of just the first one.\n\
           Returns the list of baking slots. Also returns the minimal \
           timestamps that correspond to these slots. The timestamps are \
           omitted for levels in the past, and are only estimates for levels \
           later that the next block, based on the hypothesis that all \
           predecessor blocks were baked at the first priority."
        ~query:baking_rights_query
        ~output:(list encoding)
        custom_root
  end

  let baking_priorities ctxt max_prio (level, pred_timestamp) =
    Baking.baking_priorities ctxt level
    >>=? fun contract_list ->
    let rec loop l acc priority =
      if Compare.Int.(priority >= max_prio) then return (List.rev acc)
      else
        let (Misc.LCons (pk, next)) = l in
        let delegate = Signature.Public_key.hash pk in
        ( match pred_timestamp with
        | None ->
            return_none
        | Some pred_timestamp ->
            Baking.minimal_time ctxt priority pred_timestamp
            >>=? fun t -> return_some t )
        >>=? fun timestamp ->
        let acc =
          {level = level.level; delegate; priority; timestamp} :: acc
        in
        next () >>=? fun l -> loop l acc (priority + 1)
    in
    loop contract_list [] 0

  let remove_duplicated_delegates rights =
    List.rev @@ fst
    @@ List.fold_left
         (fun (acc, previous) r ->
           if Signature.Public_key_hash.Set.mem r.delegate previous then
             (acc, previous)
           else
             (r :: acc, Signature.Public_key_hash.Set.add r.delegate previous))
         ([], Signature.Public_key_hash.Set.empty)
         rights

  let register () =
    let open Services_registration in
    register0 S.baking_rights (fun ctxt q () ->
        requested_levels
          ~default:
            ( Level.succ ctxt (Level.current ctxt),
              Some (Timestamp.current ctxt) )
          ctxt
          q.cycles
          q.levels
        >>=? fun levels ->
        let max_priority =
          match q.max_priority with None -> 64 | Some max -> max
        in
        map_s (baking_priorities ctxt max_priority) levels
        >>=? fun rights ->
        let rights =
          if q.all then rights else List.map remove_duplicated_delegates rights
        in
        let rights = List.concat rights in
        match q.delegates with
        | [] ->
            return rights
        | _ :: _ as delegates ->
            let is_requested p =
              List.exists
                (Signature.Public_key_hash.equal p.delegate)
                delegates
            in
            return (List.filter is_requested rights))

  let get ctxt ?(levels = []) ?(cycles = []) ?(delegates = []) ?(all = false)
      ?max_priority block =
    RPC_context.make_call0
      S.baking_rights
      ctxt
      block
      {levels; cycles; delegates; max_priority; all}
      ()
end

module Endorsing_rights = struct
  type t = {
    level : Raw_level.t;
    delegate : Signature.Public_key_hash.t;
    slots : int list;
    estimated_time : Time.t option;
  }

  let encoding =
    let open Data_encoding in
    conv
      (fun {level; delegate; slots; estimated_time} ->
        (level, delegate, slots, estimated_time))
      (fun (level, delegate, slots, estimated_time) ->
        {level; delegate; slots; estimated_time})
      (obj4
         (req "level" Raw_level.encoding)
         (req "delegate" Signature.Public_key_hash.encoding)
         (req "slots" (list uint16))
         (opt "estimated_time" Timestamp.encoding))

  module S = struct
    open Data_encoding

    let custom_root = RPC_path.(open_root / "helpers" / "endorsing_rights")

    type endorsing_rights_query = {
      levels : Raw_level.t list;
      cycles : Cycle.t list;
      delegates : Signature.Public_key_hash.t list;
    }

    let endorsing_rights_query =
      let open RPC_query in
      query (fun levels cycles delegates -> {levels; cycles; delegates})
      |+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels)
      |+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles)
      |+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t ->
             t.delegates)
      |> seal

    let endorsing_rights =
      RPC_service.get_service
        ~description:
          "Retrieves the delegates allowed to endorse a block.\n\
           By default, it gives the endorsement slots for delegates that have \
           at least one in the next block.\n\
           Parameters `level` and `cycle` can be used to specify the (valid) \
           level(s) in the past or future at which the endorsement rights \
           have to be returned. Parameter `delegate` can be used to restrict \
           the results to the given delegates.\n\
           Returns the list of endorsement slots. Also returns the minimal \
           timestamps that correspond to these slots. The timestamps are \
           omitted for levels in the past, and are only estimates for levels \
           later that the next block, based on the hypothesis that all \
           predecessor blocks were baked at the first priority."
        ~query:endorsing_rights_query
        ~output:(list encoding)
        custom_root
  end

  let endorsement_slots ctxt (level, estimated_time) =
    Baking.endorsement_rights ctxt level
    >>=? fun rights ->
    return
      (Signature.Public_key_hash.Map.fold
         (fun delegate (_, slots, _) acc ->
           {level = level.level; delegate; slots; estimated_time} :: acc)
         rights
         [])

  let register () =
    let open Services_registration in
    register0 S.endorsing_rights (fun ctxt q () ->
        requested_levels
          ~default:(Level.current ctxt, Some (Timestamp.current ctxt))
          ctxt
          q.cycles
          q.levels
        >>=? fun levels ->
        map_s (endorsement_slots ctxt) levels
        >>=? fun rights ->
        let rights = List.concat rights in
        match q.delegates with
        | [] ->
            return rights
        | _ :: _ as delegates ->
            let is_requested p =
              List.exists
                (Signature.Public_key_hash.equal p.delegate)
                delegates
            in
            return (List.filter is_requested rights))

  let get ctxt ?(levels = []) ?(cycles = []) ?(delegates = []) block =
    RPC_context.make_call0
      S.endorsing_rights
      ctxt
      block
      {levels; cycles; delegates}
      ()
end

module Endorsing_power = struct
  let endorsing_power ctxt (operation, chain_id) =
    let (Operation_data data) = operation.protocol_data in
    match data.contents with
    | Single (Endorsement _) ->
        Baking.check_endorsement_rights
          ctxt
          chain_id
          {shell = operation.shell; protocol_data = data}
        >>=? fun (_, slots, _) -> return (List.length slots)
    | _ ->
        failwith "Operation is not an endorsement"

  module S = struct
    let endorsing_power =
      let open Data_encoding in
      RPC_service.post_service
        ~description:
          "Get the endorsing power of an endorsement, that is, the number of \
           slots that the endorser has"
        ~query:RPC_query.empty
        ~input:
          (obj2
             (req "endorsement_operation" Operation.encoding)
             (req "chain_id" Chain_id.encoding))
        ~output:int31
        RPC_path.(open_root / "endorsing_power")
  end

  let register () =
    let open Services_registration in
    register0 S.endorsing_power (fun ctxt () (op, chain_id) ->
        endorsing_power ctxt (op, chain_id))

  let get ctxt block op chain_id =
    RPC_context.make_call0 S.endorsing_power ctxt block () (op, chain_id)
end

module Required_endorsements = struct
  let required_endorsements ctxt block_delay =
    return (Baking.minimum_allowed_endorsements ctxt ~block_delay)

  module S = struct
    type t = {block_delay : Period.t}

    let required_endorsements_query =
      let open RPC_query in
      query (fun block_delay -> {block_delay})
      |+ field "block_delay" Period.rpc_arg Period.zero (fun t ->
             t.block_delay)
      |> seal

    let required_endorsements =
      let open Data_encoding in
      RPC_service.get_service
        ~description:
          "Minimum number of endorsements for a block to be valid, given a \
           delay of the block's timestamp with respect to the minimum time to \
           bake at the block's priority"
        ~query:required_endorsements_query
        ~output:int31
        RPC_path.(open_root / "required_endorsements")
  end

  let register () =
    let open Services_registration in
    register0 S.required_endorsements (fun ctxt {block_delay} () ->
        required_endorsements ctxt block_delay)

  let get ctxt block block_delay =
    RPC_context.make_call0 S.required_endorsements ctxt block {block_delay} ()
end

module Minimal_valid_time = struct
  let minimal_valid_time ctxt ~priority ~endorsing_power =
    Baking.minimal_valid_time ctxt ~priority ~endorsing_power

  module S = struct
    type t = {priority : int; endorsing_power : int}

    let minimal_valid_time_query =
      let open RPC_query in
      query (fun priority endorsing_power -> {priority; endorsing_power})
      |+ field "priority" RPC_arg.int 0 (fun t -> t.priority)
      |+ field "endorsing_power" RPC_arg.int 0 (fun t -> t.endorsing_power)
      |> seal

    let minimal_valid_time =
      RPC_service.get_service
        ~description:
          "Minimal valid time for a block given a priority and an endorsing \
           power."
        ~query:minimal_valid_time_query
        ~output:Time.encoding
        RPC_path.(open_root / "minimal_valid_time")
  end

  let register () =
    let open Services_registration in
    register0 S.minimal_valid_time (fun ctxt {priority; endorsing_power} () ->
        minimal_valid_time ctxt ~priority ~endorsing_power)

  let get ctxt block priority endorsing_power =
    RPC_context.make_call0
      S.minimal_valid_time
      ctxt
      block
      {priority; endorsing_power}
      ()
end

let register () =
  register () ;
  Baking_rights.register () ;
  Endorsing_rights.register () ;
  Endorsing_power.register () ;
  Required_endorsements.register () ;
  Minimal_valid_time.register ()

let endorsement_rights ctxt level =
  Endorsing_rights.endorsement_slots ctxt (level, None)
  >>=? fun l ->
  return (List.map (fun {Endorsing_rights.delegate; _} -> delegate) l)

let baking_rights ctxt max_priority =
  let max = match max_priority with None -> 64 | Some m -> m in
  let level = Level.current ctxt in
  Baking_rights.baking_priorities ctxt max (level, None)
  >>=? fun l ->
  return
    ( level.level,
      List.map
        (fun {Baking_rights.delegate; timestamp; _} -> (delegate, timestamp))
        l )

let endorsing_power ctxt operation =
  Endorsing_power.endorsing_power ctxt operation

let required_endorsements ctxt delay =
  Required_endorsements.required_endorsements ctxt delay

let minimal_valid_time ctxt priority endorsing_power =
  Minimal_valid_time.minimal_valid_time ctxt priority endorsing_power
Delegate_services.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Baking.
Require Tezos.Contract_repr.
Require Tezos.Misc.
Require Tezos.Services_registration.

Import Alpha_context.

Module info.
  Record record := Build {
    balance : Alpha_context.Tez.t;
    frozen_balance : Alpha_context.Tez.t;
    frozen_balance_by_cycle :
      (|Alpha_context.Cycle.Map|).(S.MAP.t)
        Alpha_context.Delegate.frozen_balance;
    staking_balance : Alpha_context.Tez.t;
    delegated_contracts : list Contract_repr.t;
    delegated_balance : Alpha_context.Tez.t;
    deactivated : bool;
    grace_period : Alpha_context.Cycle.t }.
  Definition with_balance balance (r : record) :=
    Build balance r.(frozen_balance) r.(frozen_balance_by_cycle)
      r.(staking_balance) r.(delegated_contracts) r.(delegated_balance)
      r.(deactivated) r.(grace_period).
  Definition with_frozen_balance frozen_balance (r : record) :=
    Build r.(balance) frozen_balance r.(frozen_balance_by_cycle)
      r.(staking_balance) r.(delegated_contracts) r.(delegated_balance)
      r.(deactivated) r.(grace_period).
  Definition with_frozen_balance_by_cycle frozen_balance_by_cycle
    (r : record) :=
    Build r.(balance) r.(frozen_balance) frozen_balance_by_cycle
      r.(staking_balance) r.(delegated_contracts) r.(delegated_balance)
      r.(deactivated) r.(grace_period).
  Definition with_staking_balance staking_balance (r : record) :=
    Build r.(balance) r.(frozen_balance) r.(frozen_balance_by_cycle)
      staking_balance r.(delegated_contracts) r.(delegated_balance)
      r.(deactivated) r.(grace_period).
  Definition with_delegated_contracts delegated_contracts (r : record) :=
    Build r.(balance) r.(frozen_balance) r.(frozen_balance_by_cycle)
      r.(staking_balance) delegated_contracts r.(delegated_balance)
      r.(deactivated) r.(grace_period).
  Definition with_delegated_balance delegated_balance (r : record) :=
    Build r.(balance) r.(frozen_balance) r.(frozen_balance_by_cycle)
      r.(staking_balance) r.(delegated_contracts) delegated_balance
      r.(deactivated) r.(grace_period).
  Definition with_deactivated deactivated (r : record) :=
    Build r.(balance) r.(frozen_balance) r.(frozen_balance_by_cycle)
      r.(staking_balance) r.(delegated_contracts) r.(delegated_balance)
      deactivated r.(grace_period).
  Definition with_grace_period grace_period (r : record) :=
    Build r.(balance) r.(frozen_balance) r.(frozen_balance_by_cycle)
      r.(staking_balance) r.(delegated_contracts) r.(delegated_balance)
      r.(deactivated) grace_period.
End info.
Definition info := info.record.

Definition info_encoding : Data_encoding.encoding info :=
  Data_encoding.conv
    (fun function_parameter =>
      let '{|
        info.balance := balance;
          info.frozen_balance := frozen_balance;
          info.frozen_balance_by_cycle := frozen_balance_by_cycle;
          info.staking_balance := staking_balance;
          info.delegated_contracts := delegated_contracts;
          info.delegated_balance := delegated_balance;
          info.deactivated := deactivated;
          info.grace_period := grace_period
          |} := function_parameter in
      (balance, frozen_balance, frozen_balance_by_cycle, staking_balance,
        delegated_contracts, delegated_balance, deactivated, grace_period))
    (fun function_parameter =>
      let
        '(balance, frozen_balance, frozen_balance_by_cycle, staking_balance,
          delegated_contracts, delegated_balance, deactivated, grace_period) :=
        function_parameter in
      {| info.balance := balance; info.frozen_balance := frozen_balance;
        info.frozen_balance_by_cycle := frozen_balance_by_cycle;
        info.staking_balance := staking_balance;
        info.delegated_contracts := delegated_contracts;
        info.delegated_balance := delegated_balance;
        info.deactivated := deactivated; info.grace_period := grace_period |})
    None
    (Data_encoding.obj8
      (Data_encoding.req None None "balance" Alpha_context.Tez.encoding)
      (Data_encoding.req None None "frozen_balance" Alpha_context.Tez.encoding)
      (Data_encoding.req None None "frozen_balance_by_cycle"
        Alpha_context.Delegate.frozen_balance_by_cycle_encoding)
      (Data_encoding.req None None "staking_balance" Alpha_context.Tez.encoding)
      (Data_encoding.req None None "delegated_contracts"
        (Data_encoding.__list_value None Contract_repr.encoding))
      (Data_encoding.req None None "delegated_balance"
        Alpha_context.Tez.encoding)
      (Data_encoding.req None None "deactivated" Data_encoding.__bool_value)
      (Data_encoding.req None None "grace_period" Alpha_context.Cycle.encoding)).

Module S.
  Definition path : RPC_path.path Updater.rpc_context Updater.rpc_context :=
    RPC_path.op_div (RPC_path.op_div RPC_path.open_root "context") "delegates".
  
  Import Data_encoding.
  
  Module list_query.
    Record record := Build {
      active : bool;
      inactive : bool }.
    Definition with_active active (r : record) :=
      Build active r.(inactive).
    Definition with_inactive inactive (r : record) :=
      Build r.(active) inactive.
  End list_query.
  Definition list_query := list_query.record.
  
  Definition list_query : RPC_query.t list_query :=
    Pervasives.op_pipegt
      (RPC_query.op_pipeplus
        (RPC_query.op_pipeplus
          (RPC_query.__query_value
            (fun active =>
              fun inactive =>
                {| list_query.active := active; list_query.inactive := inactive
                  |}))
          (RPC_query.flag None "active"
            (fun __t_value => list_query.active __t_value)))
        (RPC_query.flag None "inactive"
          (fun __t_value => list_query.inactive __t_value))) RPC_query.seal.
  
  Definition list_delegate
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      Updater.rpc_context list_query unit
      (list (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) :=
    RPC_service.get_service (Some "Lists all registered delegates.") list_query
      (Data_encoding.__list_value None
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding)) path.
  
  Definition path
    : RPC_path.path Updater.rpc_context
      (Updater.rpc_context *
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) :=
    RPC_path.op_divcolon path
      (|Signature.Public_key_hash|).(S.SPublic_key_hash.rpc_arg).
  
  Definition info
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      (Updater.rpc_context *
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) unit unit info :=
    RPC_service.get_service (Some "Everything about a delegate.")
      RPC_query.empty info_encoding path.
  
  Definition balance
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      (Updater.rpc_context *
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) unit unit
      Alpha_context.Tez.t :=
    RPC_service.get_service
      (Some
        "Returns the full balance of a given delegate, including the frozen balances.")
      RPC_query.empty Alpha_context.Tez.encoding
      (RPC_path.op_div path "balance").
  
  Definition frozen_balance
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      (Updater.rpc_context *
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) unit unit
      Alpha_context.Tez.t :=
    RPC_service.get_service
      (Some
        "Returns the total frozen balances of a given delegate, this includes the frozen deposits, rewards and fees.")
      RPC_query.empty Alpha_context.Tez.encoding
      (RPC_path.op_div path "frozen_balance").
  
  Definition frozen_balance_by_cycle
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      (Updater.rpc_context *
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) unit unit
      ((|Alpha_context.Cycle.Map|).(S.MAP.t)
        Alpha_context.Delegate.frozen_balance) :=
    RPC_service.get_service
      (Some
        "Returns the frozen balances of a given delegate, indexed by the cycle by which it will be unfrozen")
      RPC_query.empty Alpha_context.Delegate.frozen_balance_by_cycle_encoding
      (RPC_path.op_div path "frozen_balance_by_cycle").
  
  Definition staking_balance
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      (Updater.rpc_context *
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) unit unit
      Alpha_context.Tez.t :=
    RPC_service.get_service
      (Some
        "Returns the total amount of tokens delegated to a given delegate. This includes the balances of all the contracts that delegate to it, but also the balance of the delegate itself and its frozen fees and deposits. The rewards do not count in the delegated balance until they are unfrozen.")
      RPC_query.empty Alpha_context.Tez.encoding
      (RPC_path.op_div path "staking_balance").
  
  Definition delegated_contracts
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      (Updater.rpc_context *
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) unit unit
      (list Contract_repr.contract) :=
    RPC_service.get_service
      (Some "Returns the list of contracts that delegate to a given delegate.")
      RPC_query.empty (Data_encoding.__list_value None Contract_repr.encoding)
      (RPC_path.op_div path "delegated_contracts").
  
  Definition delegated_balance
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      (Updater.rpc_context *
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) unit unit
      Alpha_context.Tez.t :=
    RPC_service.get_service
      (Some
        "Returns the balances of all the contracts that delegate to a given delegate. This excludes the delegate's own balance and its frozen balances.")
      RPC_query.empty Alpha_context.Tez.encoding
      (RPC_path.op_div path "delegated_balance").
  
  Definition deactivated
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      (Updater.rpc_context *
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) unit unit bool :=
    RPC_service.get_service
      (Some
        "Tells whether the delegate is currently tagged as deactivated or not.")
      RPC_query.empty Data_encoding.__bool_value
      (RPC_path.op_div path "deactivated").
  
  Definition grace_period
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      (Updater.rpc_context *
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) unit unit
      Alpha_context.Cycle.t :=
    RPC_service.get_service
      (Some
        "Returns the cycle by the end of which the delegate might be deactivated if she fails to execute any delegate action. A deactivated delegate might be reactivated (without loosing any rolls) by simply re-registering as a delegate. For deactivated delegates, this value contains the cycle by which they were deactivated.")
      RPC_query.empty Alpha_context.Cycle.encoding
      (RPC_path.op_div path "grace_period").
End S.

Definition register (function_parameter : unit) : unit :=
  let '_ := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  Services_registration.register1 S.grace_period
    (fun ctxt =>
      fun pkh =>
        fun function_parameter =>
          let '_ := function_parameter in
          fun function_parameter =>
            let '_ := function_parameter in
            Alpha_context.Delegate.grace_period ctxt pkh).

Definition __list_value {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (op_staroptstar : option bool)
  : option bool -> unit ->
  Lwt.t
    (Error_monad.shell_tzresult
      (list (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))) :=
  let active :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => true
    end in
  fun op_staroptstar =>
    let inactive :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun function_parameter =>
      let '_ := function_parameter in
      RPC_context.make_call0 S.list_delegate ctxt block
        {| S.list_query.active := active; S.list_query.inactive := inactive |}
        tt.

Definition info {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (pkh : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.shell_tzresult info) :=
  RPC_context.make_call1 S.info ctxt block pkh tt tt.

Definition balance {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (pkh : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.shell_tzresult Alpha_context.Tez.t) :=
  RPC_context.make_call1 S.balance ctxt block pkh tt tt.

Definition frozen_balance {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (pkh : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.shell_tzresult Alpha_context.Tez.t) :=
  RPC_context.make_call1 S.frozen_balance ctxt block pkh tt tt.

Definition frozen_balance_by_cycle {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (pkh : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t
    (Error_monad.shell_tzresult
      ((|Alpha_context.Cycle.Map|).(S.MAP.t)
        Alpha_context.Delegate.frozen_balance)) :=
  RPC_context.make_call1 S.frozen_balance_by_cycle ctxt block pkh tt tt.

Definition staking_balance {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (pkh : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.shell_tzresult Alpha_context.Tez.t) :=
  RPC_context.make_call1 S.staking_balance ctxt block pkh tt tt.

Definition delegated_contracts {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (pkh : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.shell_tzresult (list Contract_repr.contract)) :=
  RPC_context.make_call1 S.delegated_contracts ctxt block pkh tt tt.

Definition delegated_balance {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (pkh : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.shell_tzresult Alpha_context.Tez.t) :=
  RPC_context.make_call1 S.delegated_balance ctxt block pkh tt tt.

Definition deactivated {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (pkh : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.shell_tzresult bool) :=
  RPC_context.make_call1 S.deactivated ctxt block pkh tt tt.

Definition grace_period {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  (pkh : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.shell_tzresult Alpha_context.Cycle.t) :=
  RPC_context.make_call1 S.grace_period ctxt block pkh tt tt.

Definition requested_levels
  (default : Alpha_context.Level.t * option Alpha_context.Timestamp.t)
  (ctxt : Alpha_context.context) (cycles : list Alpha_context.Cycle.t)
  (levels : list Alpha_context.Raw_level.t)
  : Lwt.t
    (Error_monad.tzresult
      (list (Alpha_context.Level.t * option Alpha_context.Timestamp.t))) :=
  match (levels, cycles) with
  | ([], []) => Error_monad.__return [ default ]
  | (levels, cycles) =>
    let levels :=
      List.sort_uniq Alpha_context.Level.compare
        (List.concat
          (cons
            (List.map
              (let arg := Alpha_context.Level.from_raw ctxt in
              fun eta => arg None eta) levels)
            (List.map (Alpha_context.Level.levels_in_cycle ctxt) cycles))) in
    Error_monad.map_s
      (fun level =>
        let current_level := Alpha_context.Level.current ctxt in
        if Alpha_context.Level.op_lteq level current_level then
          Error_monad.__return (level, None)
        else
          Error_monad.op_gtgteqquestion
            (Baking.earlier_predecessor_timestamp ctxt level)
            (fun timestamp => Error_monad.__return (level, (Some timestamp))))
      levels
  end.

Module Baking_rights.
  Module t.
    Record record := Build {
      level : Alpha_context.Raw_level.t;
      delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
      priority : Z;
      timestamp : option Alpha_context.Timestamp.t }.
    Definition with_level level (r : record) :=
      Build level r.(delegate) r.(priority) r.(timestamp).
    Definition with_delegate delegate (r : record) :=
      Build r.(level) delegate r.(priority) r.(timestamp).
    Definition with_priority priority (r : record) :=
      Build r.(level) r.(delegate) priority r.(timestamp).
    Definition with_timestamp timestamp (r : record) :=
      Build r.(level) r.(delegate) r.(priority) timestamp.
  End t.
  Definition t := t.record.
  
  Definition encoding : Data_encoding.encoding t :=
    Data_encoding.conv
      (fun function_parameter =>
        let '{|
          t.level := level;
            t.delegate := delegate;
            t.priority := priority;
            t.timestamp := timestamp
            |} := function_parameter in
        (level, delegate, priority, timestamp))
      (fun function_parameter =>
        let '(level, delegate, priority, timestamp) := function_parameter in
        {| t.level := level; t.delegate := delegate; t.priority := priority;
          t.timestamp := timestamp |}) None
      (Data_encoding.obj4
        (Data_encoding.req None None "level" Alpha_context.Raw_level.encoding)
        (Data_encoding.req None None "delegate"
          (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding))
        (Data_encoding.req None None "priority" Data_encoding.uint16)
        (Data_encoding.opt None None "estimated_time"
          Alpha_context.Timestamp.encoding)).
  
  Module S.
    Import Data_encoding.
    
    Definition custom_root
      : RPC_path.path Updater.rpc_context Updater.rpc_context :=
      RPC_path.op_div (RPC_path.op_div RPC_path.open_root "helpers")
        "baking_rights".
    
    Module baking_rights_query.
      Record record := Build {
        levels : list Alpha_context.Raw_level.t;
        cycles : list Alpha_context.Cycle.t;
        delegates : list (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
        max_priority : option Z;
        all : bool }.
      Definition with_levels levels (r : record) :=
        Build levels r.(cycles) r.(delegates) r.(max_priority) r.(all).
      Definition with_cycles cycles (r : record) :=
        Build r.(levels) cycles r.(delegates) r.(max_priority) r.(all).
      Definition with_delegates delegates (r : record) :=
        Build r.(levels) r.(cycles) delegates r.(max_priority) r.(all).
      Definition with_max_priority max_priority (r : record) :=
        Build r.(levels) r.(cycles) r.(delegates) max_priority r.(all).
      Definition with_all all (r : record) :=
        Build r.(levels) r.(cycles) r.(delegates) r.(max_priority) all.
    End baking_rights_query.
    Definition baking_rights_query := baking_rights_query.record.
    
    Definition baking_rights_query : RPC_query.t baking_rights_query :=
      Pervasives.op_pipegt
        (RPC_query.op_pipeplus
          (RPC_query.op_pipeplus
            (RPC_query.op_pipeplus
              (RPC_query.op_pipeplus
                (RPC_query.op_pipeplus
                  (RPC_query.__query_value
                    (fun levels =>
                      fun cycles =>
                        fun delegates =>
                          fun max_priority =>
                            fun all =>
                              {| baking_rights_query.levels := levels;
                                baking_rights_query.cycles := cycles;
                                baking_rights_query.delegates := delegates;
                                baking_rights_query.max_priority := max_priority;
                                baking_rights_query.all := all |}))
                  (RPC_query.multi_field None "level"
                    Alpha_context.Raw_level.rpc_arg
                    (fun __t_value => baking_rights_query.levels __t_value)))
                (RPC_query.multi_field None "cycle" Alpha_context.Cycle.rpc_arg
                  (fun __t_value => baking_rights_query.cycles __t_value)))
              (RPC_query.multi_field None "delegate"
                (|Signature.Public_key_hash|).(S.SPublic_key_hash.rpc_arg)
                (fun __t_value => baking_rights_query.delegates __t_value)))
            (RPC_query.opt_field None "max_priority" RPC_arg.int
              (fun __t_value => baking_rights_query.max_priority __t_value)))
          (RPC_query.flag None "all"
            (fun __t_value => baking_rights_query.all __t_value)))
        RPC_query.seal.
    
    Definition baking_rights
      : RPC_service.service (* `GET *) unit Updater.rpc_context
        Updater.rpc_context baking_rights_query unit (list t) :=
      RPC_service.get_service
        (Some
          "Retrieves the list of delegates allowed to bake a block.\nBy default, it gives the best baking priorities for bakers that have at least one opportunity below the 64th priority for the next block.\nParameters `level` and `cycle` can be used to specify the (valid) level(s) in the past or future at which the baking rights have to be returned. Parameter `delegate` can be used to restrict the results to the given delegates. If parameter `all` is set, all the baking opportunities for each baker at each level are returned, instead of just the first one.\nReturns the list of baking slots. Also returns the minimal timestamps that correspond to these slots. The timestamps are omitted for levels in the past, and are only estimates for levels later that the next block, based on the hypothesis that all predecessor blocks were baked at the first priority.")
        baking_rights_query (Data_encoding.__list_value None encoding)
        custom_root.
  End S.
  
  Definition baking_priorities
    (ctxt : Alpha_context.context) (max_prio : (|Compare.Int|).(Compare.S.t))
    (function_parameter : Alpha_context.Level.t * option Time.t)
    : Lwt.t (Error_monad.tzresult (list t)) :=
    let '(level, pred_timestamp) := function_parameter in
    Error_monad.op_gtgteqquestion (Baking.baking_priorities ctxt level)
      (fun contract_list =>
        let fix loop
          (l : Misc.lazy_list_t (|Signature.Public_key|).(S.SPublic_key.t))
          (acc : list t) (priority : (|Compare.Int|).(Compare.S.t)) {struct l}
          : Lwt.t (Error_monad.tzresult (list t)) :=
          if (|Compare.Int|).(Compare.S.op_gteq) priority max_prio then
            Error_monad.__return (List.rev acc)
          else
            let 'Misc.LCons pk next := l in
            let delegate :=
              (|Signature.Public_key|).(S.SPublic_key.__hash_value) pk in
            Error_monad.op_gtgteqquestion
              match pred_timestamp with
              | None => Error_monad.return_none
              | Some pred_timestamp =>
                Error_monad.op_gtgteqquestion
                  (Baking.minimal_time ctxt priority pred_timestamp)
                  (fun __t_value => Error_monad.return_some __t_value)
              end
              (fun timestamp =>
                let acc :=
                  cons
                    {| t.level := Alpha_context.Level.t.level level;
                      t.delegate := delegate; t.priority := priority;
                      t.timestamp := timestamp |} acc in
                Error_monad.op_gtgteqquestion (next tt)
                  (fun l => loop l acc (Pervasives.op_plus priority 1))) in
        loop contract_list [] 0).
  
  Definition remove_duplicated_delegates (rights : list t) : list t :=
    Pervasives.op_atat List.rev
      (Pervasives.op_atat Pervasives.fst
        (List.fold_left
          (fun function_parameter =>
            let '(acc, previous) := function_parameter in
            fun r =>
              if
                (|Signature.Public_key_hash|).(S.SPublic_key_hash.__Set).(S.INDEXES_Set.mem)
                  (t.delegate r) previous then
                (acc, previous)
              else
                ((cons r acc),
                  ((|Signature.Public_key_hash|).(S.SPublic_key_hash.__Set).(S.INDEXES_Set.add)
                    (t.delegate r) previous)))
          ([],
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.__Set).(S.INDEXES_Set.empty))
          rights)).
  
  Definition register (function_parameter : unit) : unit :=
    let '_ := function_parameter in
    Services_registration.register0 S.baking_rights
      (fun ctxt =>
        fun q =>
          fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (requested_levels
                ((Alpha_context.Level.succ ctxt
                  (Alpha_context.Level.current ctxt)),
                  (Some (Alpha_context.Timestamp.current ctxt))) ctxt
                (S.baking_rights_query.cycles q)
                (S.baking_rights_query.levels q))
              (fun levels =>
                let max_priority :=
                  match S.baking_rights_query.max_priority q with
                  | None => 64
                  | Some max => max
                  end in
                Error_monad.op_gtgteqquestion
                  (Error_monad.map_s (baking_priorities ctxt max_priority)
                    levels)
                  (fun rights =>
                    let rights :=
                      if S.baking_rights_query.all q then
                        rights
                      else
                        List.map remove_duplicated_delegates rights in
                    let rights := List.concat rights in
                    match S.baking_rights_query.delegates q with
                    | [] => Error_monad.__return rights
                    | (cons _ _) as delegates =>
                      let is_requested (p : t) : bool :=
                        List.__exists
                          ((|Signature.Public_key_hash|).(S.SPublic_key_hash.equal)
                            (t.delegate p)) delegates in
                      Error_monad.__return (List.filter is_requested rights)
                    end))).
  
  Definition get {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D)
    (op_staroptstar : option (list Alpha_context.Raw_level.t))
    : option (list Alpha_context.Cycle.t) ->
    option (list (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) ->
    option bool -> option Z -> D -> Lwt.t (Error_monad.shell_tzresult (list t)) :=
    let levels :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => []
      end in
    fun op_staroptstar =>
      let cycles :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => []
        end in
      fun op_staroptstar =>
        let delegates :=
          match op_staroptstar with
          | Some op_starsthstar => op_starsthstar
          | None => []
          end in
        fun op_staroptstar =>
          let all :=
            match op_staroptstar with
            | Some op_starsthstar => op_starsthstar
            | None => false
            end in
          fun max_priority =>
            fun block =>
              RPC_context.make_call0 S.baking_rights ctxt block
                {| S.baking_rights_query.levels := levels;
                  S.baking_rights_query.cycles := cycles;
                  S.baking_rights_query.delegates := delegates;
                  S.baking_rights_query.max_priority := max_priority;
                  S.baking_rights_query.all := all |} tt.
End Baking_rights.

Module Endorsing_rights.
  Module t.
    Record record := Build {
      level : Alpha_context.Raw_level.t;
      delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
      slots : list Z;
      estimated_time : option Time.t }.
    Definition with_level level (r : record) :=
      Build level r.(delegate) r.(slots) r.(estimated_time).
    Definition with_delegate delegate (r : record) :=
      Build r.(level) delegate r.(slots) r.(estimated_time).
    Definition with_slots slots (r : record) :=
      Build r.(level) r.(delegate) slots r.(estimated_time).
    Definition with_estimated_time estimated_time (r : record) :=
      Build r.(level) r.(delegate) r.(slots) estimated_time.
  End t.
  Definition t := t.record.
  
  Definition encoding : Data_encoding.encoding t :=
    Data_encoding.conv
      (fun function_parameter =>
        let '{|
          t.level := level;
            t.delegate := delegate;
            t.slots := slots;
            t.estimated_time := estimated_time
            |} := function_parameter in
        (level, delegate, slots, estimated_time))
      (fun function_parameter =>
        let '(level, delegate, slots, estimated_time) := function_parameter in
        {| t.level := level; t.delegate := delegate; t.slots := slots;
          t.estimated_time := estimated_time |}) None
      (Data_encoding.obj4
        (Data_encoding.req None None "level" Alpha_context.Raw_level.encoding)
        (Data_encoding.req None None "delegate"
          (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding))
        (Data_encoding.req None None "slots"
          (Data_encoding.__list_value None Data_encoding.uint16))
        (Data_encoding.opt None None "estimated_time"
          Alpha_context.Timestamp.encoding)).
  
  Module S.
    Import Data_encoding.
    
    Definition custom_root
      : RPC_path.path Updater.rpc_context Updater.rpc_context :=
      RPC_path.op_div (RPC_path.op_div RPC_path.open_root "helpers")
        "endorsing_rights".
    
    Module endorsing_rights_query.
      Record record := Build {
        levels : list Alpha_context.Raw_level.t;
        cycles : list Alpha_context.Cycle.t;
        delegates : list (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) }.
      Definition with_levels levels (r : record) :=
        Build levels r.(cycles) r.(delegates).
      Definition with_cycles cycles (r : record) :=
        Build r.(levels) cycles r.(delegates).
      Definition with_delegates delegates (r : record) :=
        Build r.(levels) r.(cycles) delegates.
    End endorsing_rights_query.
    Definition endorsing_rights_query := endorsing_rights_query.record.
    
    Definition endorsing_rights_query : RPC_query.t endorsing_rights_query :=
      Pervasives.op_pipegt
        (RPC_query.op_pipeplus
          (RPC_query.op_pipeplus
            (RPC_query.op_pipeplus
              (RPC_query.__query_value
                (fun levels =>
                  fun cycles =>
                    fun delegates =>
                      {| endorsing_rights_query.levels := levels;
                        endorsing_rights_query.cycles := cycles;
                        endorsing_rights_query.delegates := delegates |}))
              (RPC_query.multi_field None "level"
                Alpha_context.Raw_level.rpc_arg
                (fun __t_value => endorsing_rights_query.levels __t_value)))
            (RPC_query.multi_field None "cycle" Alpha_context.Cycle.rpc_arg
              (fun __t_value => endorsing_rights_query.cycles __t_value)))
          (RPC_query.multi_field None "delegate"
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.rpc_arg)
            (fun __t_value => endorsing_rights_query.delegates __t_value)))
        RPC_query.seal.
    
    Definition endorsing_rights
      : RPC_service.service (* `GET *) unit Updater.rpc_context
        Updater.rpc_context endorsing_rights_query unit (list t) :=
      RPC_service.get_service
        (Some
          "Retrieves the delegates allowed to endorse a block.\nBy default, it gives the endorsement slots for delegates that have at least one in the next block.\nParameters `level` and `cycle` can be used to specify the (valid) level(s) in the past or future at which the endorsement rights have to be returned. Parameter `delegate` can be used to restrict the results to the given delegates.\nReturns the list of endorsement slots. Also returns the minimal timestamps that correspond to these slots. The timestamps are omitted for levels in the past, and are only estimates for levels later that the next block, based on the hypothesis that all predecessor blocks were baked at the first priority.")
        endorsing_rights_query (Data_encoding.__list_value None encoding)
        custom_root.
  End S.
  
  Definition endorsement_slots
    (ctxt : Alpha_context.context)
    (function_parameter : Alpha_context.Level.t * option Time.t)
    : Lwt.t (Error_monad.tzresult (list t)) :=
    let '(level, estimated_time) := function_parameter in
    Error_monad.op_gtgteqquestion (Baking.endorsement_rights ctxt level)
      (fun rights =>
        Error_monad.__return
          ((|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.fold)
            (fun delegate =>
              fun function_parameter =>
                let '(_, slots, _) := function_parameter in
                fun acc =>
                  cons
                    {| t.level := Alpha_context.Level.t.level level;
                      t.delegate := delegate; t.slots := slots;
                      t.estimated_time := estimated_time |} acc) rights [])).
  
  Definition register (function_parameter : unit) : unit :=
    let '_ := function_parameter in
    Services_registration.register0 S.endorsing_rights
      (fun ctxt =>
        fun q =>
          fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (requested_levels
                ((Alpha_context.Level.current ctxt),
                  (Some (Alpha_context.Timestamp.current ctxt))) ctxt
                (S.endorsing_rights_query.cycles q)
                (S.endorsing_rights_query.levels q))
              (fun levels =>
                Error_monad.op_gtgteqquestion
                  (Error_monad.map_s (endorsement_slots ctxt) levels)
                  (fun rights =>
                    let rights := List.concat rights in
                    match S.endorsing_rights_query.delegates q with
                    | [] => Error_monad.__return rights
                    | (cons _ _) as delegates =>
                      let is_requested (p : t) : bool :=
                        List.__exists
                          ((|Signature.Public_key_hash|).(S.SPublic_key_hash.equal)
                            (t.delegate p)) delegates in
                      Error_monad.__return (List.filter is_requested rights)
                    end))).
  
  Definition get {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D)
    (op_staroptstar : option (list Alpha_context.Raw_level.t))
    : option (list Alpha_context.Cycle.t) ->
    option (list (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) -> D ->
    Lwt.t (Error_monad.shell_tzresult (list t)) :=
    let levels :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => []
      end in
    fun op_staroptstar =>
      let cycles :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => []
        end in
      fun op_staroptstar =>
        let delegates :=
          match op_staroptstar with
          | Some op_starsthstar => op_starsthstar
          | None => []
          end in
        fun block =>
          RPC_context.make_call0 S.endorsing_rights ctxt block
            {| S.endorsing_rights_query.levels := levels;
              S.endorsing_rights_query.cycles := cycles;
              S.endorsing_rights_query.delegates := delegates |} tt.
End Endorsing_rights.

Module Endorsing_power.
  Definition endorsing_power
    (ctxt : Alpha_context.context)
    (function_parameter :
      Alpha_context.packed_operation * (|Chain_id|).(S.HASH.t))
    : Lwt.t (Error_monad.tzresult Z) :=
    let '(operation, chain_id) := function_parameter in
    let 'Alpha_context.Operation_data data :=
      Alpha_context.packed_operation.protocol_data operation in
    match Alpha_context.protocol_data.contents data with
    | Alpha_context.Single (Alpha_context.Endorsement _) =>
      Error_monad.op_gtgteqquestion
        (Baking.check_endorsement_rights ctxt chain_id
          {|
            Alpha_context.operation.shell :=
              Alpha_context.packed_operation.shell operation;
            Alpha_context.operation.protocol_data := data |})
        (fun function_parameter =>
          let '(_, slots, _) := function_parameter in
          Error_monad.__return (List.length slots))
    | _ => Pervasives.failwith "Operation is not an endorsement"
    end.
  
  Module S.
    Definition endorsing_power
      : RPC_service.service (* `POST *) unit Updater.rpc_context
        Updater.rpc_context unit
        (Alpha_context.Operation.packed * (|Chain_id|).(S.HASH.t)) Z :=
      RPC_service.post_service
        (Some
          "Get the endorsing power of an endorsement, that is, the number of slots that the endorser has")
        RPC_query.empty
        (Data_encoding.obj2
          (Data_encoding.req None None "endorsement_operation"
            Alpha_context.Operation.encoding)
          (Data_encoding.req None None "chain_id" (|Chain_id|).(S.HASH.encoding)))
        Data_encoding.int31
        (RPC_path.op_div RPC_path.open_root "endorsing_power").
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    let '_ := function_parameter in
    Services_registration.register0 S.endorsing_power
      (fun ctxt =>
        fun function_parameter =>
          let '_ := function_parameter in
          fun function_parameter =>
            let '(op, chain_id) := function_parameter in
            endorsing_power ctxt (op, chain_id)).
  
  Definition get {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    (op : Alpha_context.Operation.packed) (chain_id : (|Chain_id|).(S.HASH.t))
    : Lwt.t (Error_monad.shell_tzresult Z) :=
    RPC_context.make_call0 S.endorsing_power ctxt block tt (op, chain_id).
End Endorsing_power.

Module Required_endorsements.
  Definition required_endorsements
    (ctxt : Alpha_context.context) (block_delay : Alpha_context.Period.t)
    : Lwt.t (Error_monad.tzresult Z) :=
    Error_monad.__return (Baking.minimum_allowed_endorsements ctxt block_delay).
  
  Module S.
    Module t.
      Record record := Build {
        block_delay : Alpha_context.Period.t }.
      Definition with_block_delay block_delay (r : record) :=
        Build block_delay.
    End t.
    Definition t := t.record.
    
    Definition required_endorsements_query : RPC_query.t t :=
      Pervasives.op_pipegt
        (RPC_query.op_pipeplus
          (RPC_query.__query_value
            (fun block_delay => {| t.block_delay := block_delay |}))
          (RPC_query.__field_value None "block_delay"
            Alpha_context.Period.rpc_arg Alpha_context.Period.zero
            (fun __t_value => t.block_delay __t_value))) RPC_query.seal.
    
    Definition required_endorsements
      : RPC_service.service (* `GET *) unit Updater.rpc_context
        Updater.rpc_context t unit Z :=
      RPC_service.get_service
        (Some
          "Minimum number of endorsements for a block to be valid, given a delay of the block's timestamp with respect to the minimum time to bake at the block's priority")
        required_endorsements_query Data_encoding.int31
        (RPC_path.op_div RPC_path.open_root "required_endorsements").
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    let '_ := function_parameter in
    Services_registration.register0 S.required_endorsements
      (fun ctxt =>
        fun function_parameter =>
          let '{| S.t.block_delay := block_delay |} := function_parameter in
          fun function_parameter =>
            let '_ := function_parameter in
            required_endorsements ctxt block_delay).
  
  Definition get {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    (block_delay : Alpha_context.Period.t)
    : Lwt.t (Error_monad.shell_tzresult Z) :=
    RPC_context.make_call0 S.required_endorsements ctxt block
      {| S.t.block_delay := block_delay |} tt.
End Required_endorsements.

Module Minimal_valid_time.
  Definition minimal_valid_time
    (ctxt : Alpha_context.context) (priority : Z) (endorsing_power : Z)
    : Lwt.t (Error_monad.tzresult Time.t) :=
    Baking.minimal_valid_time ctxt priority endorsing_power.
  
  Module S.
    Module t.
      Record record := Build {
        priority : Z;
        endorsing_power : Z }.
      Definition with_priority priority (r : record) :=
        Build priority r.(endorsing_power).
      Definition with_endorsing_power endorsing_power (r : record) :=
        Build r.(priority) endorsing_power.
    End t.
    Definition t := t.record.
    
    Definition minimal_valid_time_query : RPC_query.t t :=
      Pervasives.op_pipegt
        (RPC_query.op_pipeplus
          (RPC_query.op_pipeplus
            (RPC_query.__query_value
              (fun priority =>
                fun endorsing_power =>
                  {| t.priority := priority;
                    t.endorsing_power := endorsing_power |}))
            (RPC_query.__field_value None "priority" RPC_arg.int 0
              (fun __t_value => t.priority __t_value)))
          (RPC_query.__field_value None "endorsing_power" RPC_arg.int 0
            (fun __t_value => t.endorsing_power __t_value))) RPC_query.seal.
    
    Definition minimal_valid_time
      : RPC_service.service (* `GET *) unit Updater.rpc_context
        Updater.rpc_context t unit Time.t :=
      RPC_service.get_service
        (Some
          "Minimal valid time for a block given a priority and an endorsing power.")
        minimal_valid_time_query Time.encoding
        (RPC_path.op_div RPC_path.open_root "minimal_valid_time").
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    let '_ := function_parameter in
    Services_registration.register0 S.minimal_valid_time
      (fun ctxt =>
        fun function_parameter =>
          let '{|
            S.t.priority := priority;
              S.t.endorsing_power := endorsing_power
              |} := function_parameter in
          fun function_parameter =>
            let '_ := function_parameter in
            minimal_valid_time ctxt priority endorsing_power).
  
  Definition get {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    (priority : Z) (endorsing_power : Z)
    : Lwt.t (Error_monad.shell_tzresult Time.t) :=
    RPC_context.make_call0 S.minimal_valid_time ctxt block
      {| S.t.priority := priority; S.t.endorsing_power := endorsing_power |} tt.
End Minimal_valid_time.

Definition register (function_parameter : unit) : unit :=
  let '_ := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  Minimal_valid_time.register tt.

Definition endorsement_rights
  (ctxt : Alpha_context.context) (level : Alpha_context.Level.t)
  : Lwt.t
    (Error_monad.tzresult
      (list (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))) :=
  Error_monad.op_gtgteqquestion
    (Endorsing_rights.endorsement_slots ctxt (level, None))
    (fun l =>
      Error_monad.__return
        (List.map
          (fun function_parameter =>
            let '{| Endorsing_rights.t.delegate := delegate |} :=
              function_parameter in
            delegate) l)).

Definition baking_rights
  (ctxt : Alpha_context.context)
  (max_priority : option (|Compare.Int|).(Compare.S.t))
  : Lwt.t
    (Error_monad.tzresult
      (Alpha_context.Raw_level.t *
        list
          ((|Signature.Public_key_hash|).(S.SPublic_key_hash.t) *
            option Alpha_context.Timestamp.t))) :=
  let max :=
    match max_priority with
    | None => 64
    | Some m => m
    end in
  let level := Alpha_context.Level.current ctxt in
  Error_monad.op_gtgteqquestion
    (Baking_rights.baking_priorities ctxt max (level, None))
    (fun l =>
      Error_monad.__return
        ((Alpha_context.Level.t.level level),
          (List.map
            (fun function_parameter =>
              let '{|
                Baking_rights.t.delegate := delegate;
                  Baking_rights.t.timestamp := timestamp
                  |} := function_parameter in
              (delegate, timestamp)) l))).

Definition endorsing_power
  (ctxt : Alpha_context.context)
  (operation : Alpha_context.packed_operation * (|Chain_id|).(S.HASH.t))
  : Lwt.t (Error_monad.tzresult Z) :=
  Endorsing_power.endorsing_power ctxt operation.

Definition required_endorsements
  (ctxt : Alpha_context.context) (delay : Alpha_context.Period.t)
  : Lwt.t (Error_monad.tzresult Z) :=
  Required_endorsements.required_endorsements ctxt delay.

Definition minimal_valid_time
  (ctxt : Alpha_context.context) (priority : Z) (endorsing_power : Z)
  : Lwt.t (Error_monad.tzresult Time.t) :=
  Minimal_valid_time.minimal_valid_time ctxt priority endorsing_power.

Delegate_services_mli

  • OCaml size: 211 lines
  • Coq size: 488 lines (+131% compared to OCaml)
delegate_services.mli 195 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

val list :
  'a #RPC_context.simple ->
  'a ->
  ?active:bool ->
  ?inactive:bool ->
  unit ->
  Signature.Public_key_hash.t list shell_tzresult Lwt.t

type info = {
  balance : Tez.t;
  frozen_balance : Tez.t;
  frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t;
  staking_balance : Tez.t;
  delegated_contracts : Contract_repr.t list;
  delegated_balance : Tez.t;
  deactivated : bool;
  grace_period : Cycle.t;
}

val info_encoding : info Data_encoding.t

val info :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  info shell_tzresult Lwt.t

val balance :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  Tez.t shell_tzresult Lwt.t

val frozen_balance :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  Tez.t shell_tzresult Lwt.t

val frozen_balance_by_cycle :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  Delegate.frozen_balance Cycle.Map.t shell_tzresult Lwt.t

val staking_balance :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  Tez.t shell_tzresult Lwt.t

val delegated_contracts :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  Contract_repr.t list shell_tzresult Lwt.t

val delegated_balance :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  Tez.t shell_tzresult Lwt.t

val deactivated :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  bool shell_tzresult Lwt.t

val grace_period :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  Cycle.t shell_tzresult Lwt.t

module Baking_rights : sig
  type t = {
    level : Raw_level.t;
    delegate : Signature.Public_key_hash.t;
    priority : int;
    timestamp : Timestamp.t option;
  }

  (** Retrieves the list of delegates allowed to bake a block.

      By default, it gives the best baking priorities for bakers
      that have at least one opportunity below the 64th priority for
      the next block.

      Parameters [levels] and [cycles] can be used to specify the
      (valid) level(s) in the past or future at which the baking rights
      have to be returned. Parameter [delegates] can be used to
      restrict the results to the given delegates. If parameter [all]
      is [true], all the baking opportunities for each baker at each level
      are returned, instead of just the first one.

      Returns the list of baking slots. Also returns the minimal
      timestamps that correspond to these slots. The timestamps are
      omitted for levels in the past, and are only estimates for levels
      later that the next block, based on the hypothesis that all
      predecessor blocks were baked at the first priority. *)
  val get :
    'a #RPC_context.simple ->
    ?levels:Raw_level.t list ->
    ?cycles:Cycle.t list ->
    ?delegates:Signature.public_key_hash list ->
    ?all:bool ->
    ?max_priority:int ->
    'a ->
    t list shell_tzresult Lwt.t
end

module Endorsing_rights : sig
  type t = {
    level : Raw_level.t;
    delegate : Signature.Public_key_hash.t;
    slots : int list;
    estimated_time : Timestamp.t option;
  }

  (** Retrieves the delegates allowed to endorse a block.

      By default, it gives the endorsement slots for bakers that have
      at least one in the next block.

      Parameters [levels] and [cycles] can be used to specify the
      (valid) level(s) in the past or future at which the endorsement
      rights have to be returned. Parameter [delegates] can be used to
      restrict the results to the given delegates.  Returns the list of
      endorsement slots. Also returns the minimal timestamps that
      correspond to these slots.

      Timestamps are omitted for levels in the past, and are only
      estimates for levels later that the next block, based on the
      hypothesis that all predecessor blocks were baked at the first
      priority. *)
  val get :
    'a #RPC_context.simple ->
    ?levels:Raw_level.t list ->
    ?cycles:Cycle.t list ->
    ?delegates:Signature.public_key_hash list ->
    'a ->
    t list shell_tzresult Lwt.t
end

module Endorsing_power : sig
  val get :
    'a #RPC_context.simple ->
    'a ->
    Alpha_context.packed_operation ->
    Chain_id.t ->
    int shell_tzresult Lwt.t
end

module Required_endorsements : sig
  val get :
    'a #RPC_context.simple -> 'a -> Period.t -> int shell_tzresult Lwt.t
end

module Minimal_valid_time : sig
  val get :
    'a #RPC_context.simple -> 'a -> int -> int -> Time.t shell_tzresult Lwt.t
end

(* temporary export for deprecated unit test *)
val endorsement_rights :
  Alpha_context.t -> Level.t -> public_key_hash list tzresult Lwt.t

val baking_rights :
  Alpha_context.t ->
  int option ->
  (Raw_level.t * (public_key_hash * Time.t option) list) tzresult Lwt.t

val endorsing_power :
  Alpha_context.t ->
  Alpha_context.packed_operation * Chain_id.t ->
  int tzresult Lwt.t

val required_endorsements :
  Alpha_context.t -> Alpha_context.Period.t -> int tzresult Lwt.t

val minimal_valid_time : Alpha_context.t -> int -> int -> Time.t tzresult Lwt.t

val register : unit -> unit
Delegate_services_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Contract_repr.

Parameter __list_value : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> option bool -> option bool -> unit ->
  Lwt.t
    (Error_monad.shell_tzresult
      (list (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))).

Module info.
  Record record := Build {
    balance : Alpha_context.Tez.t;
    frozen_balance : Alpha_context.Tez.t;
    frozen_balance_by_cycle :
      (|Alpha_context.Cycle.Map|).(S.MAP.t)
        Alpha_context.Delegate.frozen_balance;
    staking_balance : Alpha_context.Tez.t;
    delegated_contracts : list Contract_repr.t;
    delegated_balance : Alpha_context.Tez.t;
    deactivated : bool;
    grace_period : Alpha_context.Cycle.t }.
  Definition with_balance balance (r : record) :=
    Build balance r.(frozen_balance) r.(frozen_balance_by_cycle)
      r.(staking_balance) r.(delegated_contracts) r.(delegated_balance)
      r.(deactivated) r.(grace_period).
  Definition with_frozen_balance frozen_balance (r : record) :=
    Build r.(balance) frozen_balance r.(frozen_balance_by_cycle)
      r.(staking_balance) r.(delegated_contracts) r.(delegated_balance)
      r.(deactivated) r.(grace_period).
  Definition with_frozen_balance_by_cycle frozen_balance_by_cycle
    (r : record) :=
    Build r.(balance) r.(frozen_balance) frozen_balance_by_cycle
      r.(staking_balance) r.(delegated_contracts) r.(delegated_balance)
      r.(deactivated) r.(grace_period).
  Definition with_staking_balance staking_balance (r : record) :=
    Build r.(balance) r.(frozen_balance) r.(frozen_balance_by_cycle)
      staking_balance r.(delegated_contracts) r.(delegated_balance)
      r.(deactivated) r.(grace_period).
  Definition with_delegated_contracts delegated_contracts (r : record) :=
    Build r.(balance) r.(frozen_balance) r.(frozen_balance_by_cycle)
      r.(staking_balance) delegated_contracts r.(delegated_balance)
      r.(deactivated) r.(grace_period).
  Definition with_delegated_balance delegated_balance (r : record) :=
    Build r.(balance) r.(frozen_balance) r.(frozen_balance_by_cycle)
      r.(staking_balance) r.(delegated_contracts) delegated_balance
      r.(deactivated) r.(grace_period).
  Definition with_deactivated deactivated (r : record) :=
    Build r.(balance) r.(frozen_balance) r.(frozen_balance_by_cycle)
      r.(staking_balance) r.(delegated_contracts) r.(delegated_balance)
      deactivated r.(grace_period).
  Definition with_grace_period grace_period (r : record) :=
    Build r.(balance) r.(frozen_balance) r.(frozen_balance_by_cycle)
      r.(staking_balance) r.(delegated_contracts) r.(delegated_balance)
      r.(deactivated) grace_period.
End info.
Definition info := info.record.

Parameter info_encoding : Data_encoding.t info.

Parameter info : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.shell_tzresult info).

Parameter balance : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.shell_tzresult Alpha_context.Tez.t).

Parameter frozen_balance : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.shell_tzresult Alpha_context.Tez.t).

Parameter frozen_balance_by_cycle : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t
    (Error_monad.shell_tzresult
      ((|Alpha_context.Cycle.Map|).(S.MAP.t)
        Alpha_context.Delegate.frozen_balance)).

Parameter staking_balance : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.shell_tzresult Alpha_context.Tez.t).

Parameter delegated_contracts : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.shell_tzresult (list Contract_repr.t)).

Parameter delegated_balance : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.shell_tzresult Alpha_context.Tez.t).

Parameter deactivated : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.shell_tzresult bool).

Parameter grace_period : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.shell_tzresult Alpha_context.Cycle.t).

Module Baking_rights.
  Module t.
    Record record := Build {
      level : Alpha_context.Raw_level.t;
      delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
      priority : Z;
      timestamp : option Alpha_context.Timestamp.t }.
    Definition with_level level (r : record) :=
      Build level r.(delegate) r.(priority) r.(timestamp).
    Definition with_delegate delegate (r : record) :=
      Build r.(level) delegate r.(priority) r.(timestamp).
    Definition with_priority priority (r : record) :=
      Build r.(level) r.(delegate) priority r.(timestamp).
    Definition with_timestamp timestamp (r : record) :=
      Build r.(level) r.(delegate) r.(priority) timestamp.
  End t.
  Definition t := t.record.
  
  Parameter get : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a ->
    option (list Alpha_context.Raw_level.t) ->
    option (list Alpha_context.Cycle.t) ->
    option (list Signature.public_key_hash) -> option bool -> option Z -> a ->
    Lwt.t (Error_monad.shell_tzresult (list t)).
End Baking_rights.

Module Endorsing_rights.
  Module t.
    Record record := Build {
      level : Alpha_context.Raw_level.t;
      delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
      slots : list Z;
      estimated_time : option Alpha_context.Timestamp.t }.
    Definition with_level level (r : record) :=
      Build level r.(delegate) r.(slots) r.(estimated_time).
    Definition with_delegate delegate (r : record) :=
      Build r.(level) delegate r.(slots) r.(estimated_time).
    Definition with_slots slots (r : record) :=
      Build r.(level) r.(delegate) slots r.(estimated_time).
    Definition with_estimated_time estimated_time (r : record) :=
      Build r.(level) r.(delegate) r.(slots) estimated_time.
  End t.
  Definition t := t.record.
  
  Parameter get : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a ->
    option (list Alpha_context.Raw_level.t) ->
    option (list Alpha_context.Cycle.t) ->
    option (list Signature.public_key_hash) -> a ->
    Lwt.t (Error_monad.shell_tzresult (list t)).
End Endorsing_rights.

Module Endorsing_power.
  Parameter get : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    Alpha_context.packed_operation -> (|Chain_id|).(S.HASH.t) ->
    Lwt.t (Error_monad.shell_tzresult Z).
End Endorsing_power.

Module Required_endorsements.
  Parameter get : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    Alpha_context.Period.t -> Lwt.t (Error_monad.shell_tzresult Z).
End Required_endorsements.

Module Minimal_valid_time.
  Parameter get : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a -> Z -> Z ->
    Lwt.t (Error_monad.shell_tzresult Time.t).
End Minimal_valid_time.

Parameter endorsement_rights :
  Alpha_context.t -> Alpha_context.Level.t ->
  Lwt.t (Error_monad.tzresult (list Alpha_context.public_key_hash)).

Parameter baking_rights :
  Alpha_context.t -> option Z ->
  Lwt.t
    (Error_monad.tzresult
      (Alpha_context.Raw_level.t *
        list (Alpha_context.public_key_hash * option Time.t))).

Parameter endorsing_power :
  Alpha_context.t -> Alpha_context.packed_operation * (|Chain_id|).(S.HASH.t) ->
  Lwt.t (Error_monad.tzresult Z).

Parameter required_endorsements :
  Alpha_context.t -> Alpha_context.Period.t -> Lwt.t (Error_monad.tzresult Z).

Parameter minimal_valid_time :
  Alpha_context.t -> Z -> Z -> Lwt.t (Error_monad.tzresult Time.t).

Parameter register : unit -> unit.

Delegate_storage

  • OCaml size: 713 lines
  • Coq size: 985 lines (+38% compared to OCaml)
delegate_storage.ml 11 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type balance =
  | Contract of Contract_repr.t
  | Rewards of Signature.Public_key_hash.t * Cycle_repr.t
  | Fees of Signature.Public_key_hash.t * Cycle_repr.t
  | Deposits of Signature.Public_key_hash.t * Cycle_repr.t

let balance_encoding =
  let open Data_encoding in
  def "operation_metadata.alpha.balance"
  @@ union
       [ case
           (Tag 0)
           ~title:"Contract"
           (obj2
              (req "kind" (constant "contract"))
              (req "contract" Contract_repr.encoding))
           (function Contract c -> Some ((), c) | _ -> None)
           (fun ((), c) -> Contract c);
         case
           (Tag 1)
           ~title:"Rewards"
           (obj4
              (req "kind" (constant "freezer"))
              (req "category" (constant "rewards"))
              (req "delegate" Signature.Public_key_hash.encoding)
              (req "cycle" Cycle_repr.encoding))
           (function Rewards (d, l) -> Some ((), (), d, l) | _ -> None)
           (fun ((), (), d, l) -> Rewards (d, l));
         case
           (Tag 2)
           ~title:"Fees"
           (obj4
              (req "kind" (constant "freezer"))
              (req "category" (constant "fees"))
              (req "delegate" Signature.Public_key_hash.encoding)
              (req "cycle" Cycle_repr.encoding))
           (function Fees (d, l) -> Some ((), (), d, l) | _ -> None)
           (fun ((), (), d, l) -> Fees (d, l));
         case
           (Tag 3)
           ~title:"Deposits"
           (obj4
              (req "kind" (constant "freezer"))
              (req "category" (constant "deposits"))
              (req "delegate" Signature.Public_key_hash.encoding)
              (req "cycle" Cycle_repr.encoding))
           (function Deposits (d, l) -> Some ((), (), d, l) | _ -> None)
           (fun ((), (), d, l) -> Deposits (d, l)) ]

type balance_update = Debited of Tez_repr.t | Credited of Tez_repr.t

let balance_update_encoding =
  let open Data_encoding in
  def "operation_metadata.alpha.balance_update"
  @@ obj1
       (req
          "change"
          (conv
             (function
               | Credited v ->
                   Tez_repr.to_mutez v
               | Debited v ->
                   Int64.neg (Tez_repr.to_mutez v))
             ( Json.wrap_error
             @@ fun v ->
             if Compare.Int64.(v < 0L) then
               match Tez_repr.of_mutez (Int64.neg v) with
               | Some v ->
                   Debited v
               | None ->
                   failwith "Qty.of_mutez"
             else
               match Tez_repr.of_mutez v with
               | Some v ->
                   Credited v
               | None ->
                   failwith "Qty.of_mutez" )
             int64))

type balance_updates = (balance * balance_update) list

let balance_updates_encoding =
  let open Data_encoding in
  def "operation_metadata.alpha.balance_updates"
  @@ list (merge_objs balance_encoding balance_update_encoding)

let cleanup_balance_updates balance_updates =
  List.filter
    (fun (_, (Credited update | Debited update)) ->
      not (Tez_repr.equal update Tez_repr.zero))
    balance_updates

type frozen_balance = {
  deposit : Tez_repr.t;
  fees : Tez_repr.t;
  rewards : Tez_repr.t;
}

let frozen_balance_encoding =
  let open Data_encoding in
  conv
    (fun {deposit; fees; rewards} -> (deposit, fees, rewards))
    (fun (deposit, fees, rewards) -> {deposit; fees; rewards})
    (obj3
       (req "deposit" Tez_repr.encoding)
       (req "fees" Tez_repr.encoding)
       (req "rewards" Tez_repr.encoding))

type error +=
  | No_deletion of Signature.Public_key_hash.t (* `Permanent *)
  | Active_delegate (* `Temporary *)
  | Current_delegate (* `Temporary *)
  | Empty_delegate_account of Signature.Public_key_hash.t (* `Temporary *)
  | Balance_too_low_for_deposit of {
      delegate : Signature.Public_key_hash.t;
      deposit : Tez_repr.t;
      balance : Tez_repr.t;
    }

(* `Temporary *)

let () =
  register_error_kind
    `Permanent
    ~id:"delegate.no_deletion"
    ~title:"Forbidden delegate deletion"
    ~description:"Tried to unregister a delegate"
    ~pp:(fun ppf delegate ->
      Format.fprintf
        ppf
        "Delegate deletion is forbidden (%a)"
        Signature.Public_key_hash.pp
        delegate)
    Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
    (function No_deletion c -> Some c | _ -> None)
    (fun c -> No_deletion c) ;
  register_error_kind
    `Temporary
    ~id:"delegate.already_active"
    ~title:"Delegate already active"
    ~description:"Useless delegate reactivation"
    ~pp:(fun ppf () ->
      Format.fprintf ppf "The delegate is still active, no need to refresh it")
    Data_encoding.empty
    (function Active_delegate -> Some () | _ -> None)
    (fun () -> Active_delegate) ;
  register_error_kind
    `Temporary
    ~id:"delegate.unchanged"
    ~title:"Unchanged delegated"
    ~description:"Contract already delegated to the given delegate"
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "The contract is already delegated to the same delegate")
    Data_encoding.empty
    (function Current_delegate -> Some () | _ -> None)
    (fun () -> Current_delegate) ;
  register_error_kind
    `Permanent
    ~id:"delegate.empty_delegate_account"
    ~title:"Empty delegate account"
    ~description:
      "Cannot register a delegate when its implicit account is empty"
    ~pp:(fun ppf delegate ->
      Format.fprintf
        ppf
        "Delegate registration is forbidden when the delegate\n\
        \           implicit account is empty (%a)"
        Signature.Public_key_hash.pp
        delegate)
    Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
    (function Empty_delegate_account c -> Some c | _ -> None)
    (fun c -> Empty_delegate_account c) ;
  register_error_kind
    `Temporary
    ~id:"delegate.balance_too_low_for_deposit"
    ~title:"Balance too low for deposit"
    ~description:"Cannot freeze deposit when the balance is too low"
    ~pp:(fun ppf (delegate, balance, deposit) ->
      Format.fprintf
        ppf
        "Delegate %a has a too low balance (%a) to deposit %a"
        Signature.Public_key_hash.pp
        delegate
        Tez_repr.pp
        balance
        Tez_repr.pp
        deposit)
    Data_encoding.(
      obj3
        (req "delegate" Signature.Public_key_hash.encoding)
        (req "balance" Tez_repr.encoding)
        (req "deposit" Tez_repr.encoding))
    (function
      | Balance_too_low_for_deposit {delegate; balance; deposit} ->
          Some (delegate, balance, deposit)
      | _ ->
          None)
    (fun (delegate, balance, deposit) ->
      Balance_too_low_for_deposit {delegate; balance; deposit})

let link c contract delegate =
  Storage.Contract.Balance.get c contract
  >>=? fun balance ->
  Roll_storage.Delegate.add_amount c delegate balance
  >>=? fun c ->
  Storage.Contract.Delegated.add
    (c, Contract_repr.implicit_contract delegate)
    contract
  >>= fun c -> return c

let unlink c contract =
  Storage.Contract.Balance.get c contract
  >>=? fun balance ->
  Storage.Contract.Delegate.get_option c contract
  >>=? function
  | None ->
      return c
  | Some delegate ->
      (* Removes the balance of the contract from the delegate *)
      Roll_storage.Delegate.remove_amount c delegate balance
      >>=? fun c ->
      Storage.Contract.Delegated.del
        (c, Contract_repr.implicit_contract delegate)
        contract
      >>= fun c -> return c

let known c delegate =
  Storage.Contract.Manager.get_option
    c
    (Contract_repr.implicit_contract delegate)
  >>=? function
  | None | Some (Manager_repr.Hash _) ->
      return_false
  | Some (Manager_repr.Public_key _) ->
      return_true

(* A delegate is registered if its "implicit account" delegates to itself. *)
let registered c delegate =
  Storage.Contract.Delegate.get_option
    c
    (Contract_repr.implicit_contract delegate)
  >>=? function
  | Some current_delegate ->
      return @@ Signature.Public_key_hash.equal delegate current_delegate
  | None ->
      return_false

let init ctxt contract delegate =
  known ctxt delegate
  >>=? fun known_delegate ->
  fail_unless known_delegate (Roll_storage.Unregistered_delegate delegate)
  >>=? fun () ->
  registered ctxt delegate
  >>=? fun is_registered ->
  fail_unless is_registered (Roll_storage.Unregistered_delegate delegate)
  >>=? fun () ->
  Storage.Contract.Delegate.init ctxt contract delegate
  >>=? fun ctxt -> link ctxt contract delegate

let get = Roll_storage.get_contract_delegate

let set c contract delegate =
  match delegate with
  | None -> (
      let delete () =
        unlink c contract
        >>=? fun c ->
        Storage.Contract.Delegate.remove c contract >>= fun c -> return c
      in
      match Contract_repr.is_implicit contract with
      | Some pkh ->
          (* check if contract is a registered delegate *)
          registered c pkh
          >>=? fun is_registered ->
          if is_registered then fail (No_deletion pkh) else delete ()
      | None ->
          delete () )
  | Some delegate ->
      known c delegate
      >>=? fun known_delegate ->
      registered c delegate
      >>=? fun registered_delegate ->
      let self_delegation =
        match Contract_repr.is_implicit contract with
        | Some pkh ->
            Signature.Public_key_hash.equal pkh delegate
        | None ->
            false
      in
      if (not known_delegate) || not (registered_delegate || self_delegation)
      then fail (Roll_storage.Unregistered_delegate delegate)
      else
        Storage.Contract.Delegate.get_option c contract
        >>=? (function
               | Some current_delegate
                 when Signature.Public_key_hash.equal delegate current_delegate
                 ->
                   if self_delegation then
                     Roll_storage.Delegate.is_inactive c delegate
                     >>=? function
                     | true -> return_unit | false -> fail Active_delegate
                   else fail Current_delegate
               | None | Some _ ->
                   return_unit)
        >>=? fun () ->
        (* check if contract is a registered delegate *)
        ( match Contract_repr.is_implicit contract with
        | Some pkh ->
            registered c pkh
            >>=? fun is_registered ->
            (* allow self-delegation to re-activate *)
            if (not self_delegation) && is_registered then
              fail (No_deletion pkh)
            else return_unit
        | None ->
            return_unit )
        >>=? fun () ->
        Storage.Contract.Balance.mem c contract
        >>= fun exists ->
        fail_when
          (self_delegation && not exists)
          (Empty_delegate_account delegate)
        >>=? fun () ->
        unlink c contract
        >>=? fun c ->
        Storage.Contract.Delegate.init_set c contract delegate
        >>= fun c ->
        link c contract delegate
        >>=? fun c ->
        ( if self_delegation then
          Storage.Delegates.add c delegate
          >>= fun c ->
          Roll_storage.Delegate.set_active c delegate >>=? fun c -> return c
        else return c )
        >>=? fun c -> return c

let remove ctxt contract = unlink ctxt contract

let delegated_contracts ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  Storage.Contract.Delegated.elements (ctxt, contract)

let get_frozen_deposit ctxt contract cycle =
  Storage.Contract.Frozen_deposits.get_option (ctxt, contract) cycle
  >>=? function None -> return Tez_repr.zero | Some frozen -> return frozen

let credit_frozen_deposit ctxt delegate cycle amount =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_deposit ctxt contract cycle
  >>=? fun old_amount ->
  Lwt.return Tez_repr.(old_amount +? amount)
  >>=? fun new_amount ->
  Storage.Contract.Frozen_deposits.init_set (ctxt, contract) cycle new_amount
  >>= fun ctxt ->
  Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate
  >>= fun ctxt -> return ctxt

let freeze_deposit ctxt delegate amount =
  let {Level_repr.cycle; _} = Level_storage.current ctxt in
  Roll_storage.Delegate.set_active ctxt delegate
  >>=? fun ctxt ->
  let contract = Contract_repr.implicit_contract delegate in
  Storage.Contract.Balance.get ctxt contract
  >>=? fun balance ->
  Lwt.return
    (record_trace
       (Balance_too_low_for_deposit {delegate; deposit = amount; balance})
       Tez_repr.(balance -? amount))
  >>=? fun new_balance ->
  Storage.Contract.Balance.set ctxt contract new_balance
  >>=? fun ctxt -> credit_frozen_deposit ctxt delegate cycle amount

let get_frozen_fees ctxt contract cycle =
  Storage.Contract.Frozen_fees.get_option (ctxt, contract) cycle
  >>=? function None -> return Tez_repr.zero | Some frozen -> return frozen

let credit_frozen_fees ctxt delegate cycle amount =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_fees ctxt contract cycle
  >>=? fun old_amount ->
  Lwt.return Tez_repr.(old_amount +? amount)
  >>=? fun new_amount ->
  Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount
  >>= fun ctxt ->
  Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate
  >>= fun ctxt -> return ctxt

let freeze_fees ctxt delegate amount =
  let {Level_repr.cycle; _} = Level_storage.current ctxt in
  Roll_storage.Delegate.add_amount ctxt delegate amount
  >>=? fun ctxt -> credit_frozen_fees ctxt delegate cycle amount

let burn_fees ctxt delegate cycle amount =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_fees ctxt contract cycle
  >>=? fun old_amount ->
  ( match Tez_repr.(old_amount -? amount) with
  | Ok new_amount ->
      Roll_storage.Delegate.remove_amount ctxt delegate amount
      >>=? fun ctxt -> return (new_amount, ctxt)
  | Error _ ->
      Roll_storage.Delegate.remove_amount ctxt delegate old_amount
      >>=? fun ctxt -> return (Tez_repr.zero, ctxt) )
  >>=? fun (new_amount, ctxt) ->
  Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount
  >>= fun ctxt -> return ctxt

let get_frozen_rewards ctxt contract cycle =
  Storage.Contract.Frozen_rewards.get_option (ctxt, contract) cycle
  >>=? function None -> return Tez_repr.zero | Some frozen -> return frozen

let credit_frozen_rewards ctxt delegate cycle amount =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_rewards ctxt contract cycle
  >>=? fun old_amount ->
  Lwt.return Tez_repr.(old_amount +? amount)
  >>=? fun new_amount ->
  Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount
  >>= fun ctxt ->
  Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate
  >>= fun ctxt -> return ctxt

let freeze_rewards ctxt delegate amount =
  let {Level_repr.cycle; _} = Level_storage.current ctxt in
  credit_frozen_rewards ctxt delegate cycle amount

let burn_rewards ctxt delegate cycle amount =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_rewards ctxt contract cycle
  >>=? fun old_amount ->
  let new_amount =
    match Tez_repr.(old_amount -? amount) with
    | Error _ ->
        Tez_repr.zero
    | Ok new_amount ->
        new_amount
  in
  Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount
  >>= fun ctxt -> return ctxt

let unfreeze ctxt delegate cycle =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_deposit ctxt contract cycle
  >>=? fun deposit ->
  get_frozen_fees ctxt contract cycle
  >>=? fun fees ->
  get_frozen_rewards ctxt contract cycle
  >>=? fun rewards ->
  Storage.Contract.Balance.get ctxt contract
  >>=? fun balance ->
  Lwt.return Tez_repr.(deposit +? fees)
  >>=? fun unfrozen_amount ->
  Lwt.return Tez_repr.(unfrozen_amount +? rewards)
  >>=? fun unfrozen_amount ->
  Lwt.return Tez_repr.(balance +? unfrozen_amount)
  >>=? fun balance ->
  Storage.Contract.Balance.set ctxt contract balance
  >>=? fun ctxt ->
  Roll_storage.Delegate.add_amount ctxt delegate rewards
  >>=? fun ctxt ->
  Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle
  >>= fun ctxt ->
  Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle
  >>= fun ctxt ->
  Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle
  >>= fun ctxt ->
  return
    ( ctxt,
      cleanup_balance_updates
        [ (Deposits (delegate, cycle), Debited deposit);
          (Fees (delegate, cycle), Debited fees);
          (Rewards (delegate, cycle), Debited rewards);
          ( Contract (Contract_repr.implicit_contract delegate),
            Credited unfrozen_amount ) ] )

let cycle_end ctxt last_cycle unrevealed =
  let preserved = Constants_storage.preserved_cycles ctxt in
  ( match Cycle_repr.pred last_cycle with
  | None ->
      return (ctxt, [])
  | Some revealed_cycle ->
      List.fold_left
        (fun acc (u : Nonce_storage.unrevealed) ->
          acc
          >>=? fun (ctxt, balance_updates) ->
          burn_fees ctxt u.delegate revealed_cycle u.fees
          >>=? fun ctxt ->
          burn_rewards ctxt u.delegate revealed_cycle u.rewards
          >>=? fun ctxt ->
          let bus =
            [ (Fees (u.delegate, revealed_cycle), Debited u.fees);
              (Rewards (u.delegate, revealed_cycle), Debited u.rewards) ]
          in
          return (ctxt, bus @ balance_updates))
        (return (ctxt, []))
        unrevealed )
  >>=? fun (ctxt, balance_updates) ->
  match Cycle_repr.sub last_cycle preserved with
  | None ->
      return (ctxt, balance_updates, [])
  | Some unfrozen_cycle ->
      Storage.Delegates_with_frozen_balance.fold
        (ctxt, unfrozen_cycle)
        ~init:(Ok (ctxt, balance_updates))
        ~f:(fun delegate acc ->
          Lwt.return acc
          >>=? fun (ctxt, bus) ->
          unfreeze ctxt delegate unfrozen_cycle
          >>=? fun (ctxt, balance_updates) ->
          return (ctxt, balance_updates @ bus))
      >>=? fun (ctxt, balance_updates) ->
      Storage.Delegates_with_frozen_balance.clear (ctxt, unfrozen_cycle)
      >>= fun ctxt ->
      Storage.Active_delegates_with_rolls.fold
        ctxt
        ~init:(Ok (ctxt, []))
        ~f:(fun delegate acc ->
          Lwt.return acc
          >>=? fun (ctxt, deactivated) ->
          Storage.Contract.Delegate_desactivation.get
            ctxt
            (Contract_repr.implicit_contract delegate)
          >>=? fun cycle ->
          if Cycle_repr.(cycle <= last_cycle) then
            Roll_storage.Delegate.set_inactive ctxt delegate
            >>=? fun ctxt -> return (ctxt, delegate :: deactivated)
          else return (ctxt, deactivated))
      >>=? fun (ctxt, deactivated) ->
      return (ctxt, balance_updates, deactivated)

let punish ctxt delegate cycle =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_deposit ctxt contract cycle
  >>=? fun deposit ->
  get_frozen_fees ctxt contract cycle
  >>=? fun fees ->
  get_frozen_rewards ctxt contract cycle
  >>=? fun rewards ->
  Roll_storage.Delegate.remove_amount ctxt delegate deposit
  >>=? fun ctxt ->
  Roll_storage.Delegate.remove_amount ctxt delegate fees
  >>=? fun ctxt ->
  (* Rewards are not accounted in the delegate's rolls yet... *)
  Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle
  >>= fun ctxt ->
  Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle
  >>= fun ctxt ->
  Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle
  >>= fun ctxt -> return (ctxt, {deposit; fees; rewards})

let has_frozen_balance ctxt delegate cycle =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_deposit ctxt contract cycle
  >>=? fun deposit ->
  if Tez_repr.(deposit <> zero) then return_true
  else
    get_frozen_fees ctxt contract cycle
    >>=? fun fees ->
    if Tez_repr.(fees <> zero) then return_true
    else
      get_frozen_rewards ctxt contract cycle
      >>=? fun rewards -> return Tez_repr.(rewards <> zero)

let frozen_balance_by_cycle_encoding =
  let open Data_encoding in
  conv
    Cycle_repr.Map.bindings
    (List.fold_left
       (fun m (c, b) -> Cycle_repr.Map.add c b m)
       Cycle_repr.Map.empty)
    (list
       (merge_objs
          (obj1 (req "cycle" Cycle_repr.encoding))
          frozen_balance_encoding))

let empty_frozen_balance =
  {deposit = Tez_repr.zero; fees = Tez_repr.zero; rewards = Tez_repr.zero}

let frozen_balance_by_cycle ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  let map = Cycle_repr.Map.empty in
  Storage.Contract.Frozen_deposits.fold
    (ctxt, contract)
    ~init:map
    ~f:(fun cycle amount map ->
      Lwt.return
        (Cycle_repr.Map.add
           cycle
           {empty_frozen_balance with deposit = amount}
           map))
  >>= fun map ->
  Storage.Contract.Frozen_fees.fold
    (ctxt, contract)
    ~init:map
    ~f:(fun cycle amount map ->
      let balance =
        match Cycle_repr.Map.find_opt cycle map with
        | None ->
            empty_frozen_balance
        | Some balance ->
            balance
      in
      Lwt.return (Cycle_repr.Map.add cycle {balance with fees = amount} map))
  >>= fun map ->
  Storage.Contract.Frozen_rewards.fold
    (ctxt, contract)
    ~init:map
    ~f:(fun cycle amount map ->
      let balance =
        match Cycle_repr.Map.find_opt cycle map with
        | None ->
            empty_frozen_balance
        | Some balance ->
            balance
      in
      Lwt.return (Cycle_repr.Map.add cycle {balance with rewards = amount} map))
  >>= fun map -> Lwt.return map

let frozen_balance ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  let balance = Ok Tez_repr.zero in
  Storage.Contract.Frozen_deposits.fold
    (ctxt, contract)
    ~init:balance
    ~f:(fun _cycle amount acc ->
      Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
  >>= fun balance ->
  Storage.Contract.Frozen_fees.fold
    (ctxt, contract)
    ~init:balance
    ~f:(fun _cycle amount acc ->
      Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
  >>= fun balance ->
  Storage.Contract.Frozen_rewards.fold
    (ctxt, contract)
    ~init:balance
    ~f:(fun _cycle amount acc ->
      Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
  >>= fun balance -> Lwt.return balance

let full_balance ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  frozen_balance ctxt delegate
  >>=? fun frozen_balance ->
  Storage.Contract.Balance.get ctxt contract
  >>=? fun balance -> Lwt.return Tez_repr.(frozen_balance +? balance)

let deactivated = Roll_storage.Delegate.is_inactive

let grace_period ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  Storage.Contract.Delegate_desactivation.get ctxt contract

let staking_balance ctxt delegate =
  let token_per_rolls = Constants_storage.tokens_per_roll ctxt in
  Roll_storage.get_rolls ctxt delegate
  >>=? fun rolls ->
  Roll_storage.get_change ctxt delegate
  >>=? fun change ->
  let rolls = Int64.of_int (List.length rolls) in
  Lwt.return Tez_repr.(token_per_rolls *? rolls)
  >>=? fun balance -> Lwt.return Tez_repr.(balance +? change)

let delegated_balance ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  staking_balance ctxt delegate
  >>=? fun staking_balance ->
  Storage.Contract.Balance.get ctxt contract
  >>= fun self_staking_balance ->
  Storage.Contract.Frozen_deposits.fold
    (ctxt, contract)
    ~init:self_staking_balance
    ~f:(fun _cycle amount acc ->
      Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
  >>= fun self_staking_balance ->
  Storage.Contract.Frozen_fees.fold
    (ctxt, contract)
    ~init:self_staking_balance
    ~f:(fun _cycle amount acc ->
      Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
  >>=? fun self_staking_balance ->
  Lwt.return Tez_repr.(staking_balance -? self_staking_balance)

let fold = Storage.Delegates.fold

let list = Storage.Delegates.elements
Delegate_storage.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Constants_storage.
Require Tezos.Contract_repr.
Require Tezos.Cycle_repr.
Require Tezos.Level_repr.
Require Tezos.Level_storage.
Require Tezos.Manager_repr.
Require Tezos.Nonce_storage.
Require Tezos.Raw_context.
Require Tezos.Roll_storage.
Require Tezos.Storage.
Require Tezos.Tez_repr.

Inductive balance : Set :=
| Contract : Contract_repr.t -> balance
| Rewards :
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> Cycle_repr.t ->
  balance
| Fees :
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> Cycle_repr.t ->
  balance
| Deposits :
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> Cycle_repr.t ->
  balance.

Definition balance_encoding : Data_encoding.encoding balance :=
  Pervasives.op_atat
    (let arg := Data_encoding.def "operation_metadata.alpha.balance" in
    fun eta => arg None None eta)
    (Data_encoding.union None
      [
        Data_encoding.__case_value "Contract" None (Data_encoding.Tag 0)
          (Data_encoding.obj2
            (Data_encoding.req None None "kind"
              (Data_encoding.constant "contract"))
            (Data_encoding.req None None "contract"
              Contract_repr.encoding))
          (fun function_parameter =>
            match function_parameter with
            | Contract c => Some (tt, c)
            | _ => None
            end)
          (fun function_parameter =>
            let '(_, c) := function_parameter in
            Contract c);
        Data_encoding.__case_value "Rewards" None (Data_encoding.Tag 1)
          (Data_encoding.obj4
            (Data_encoding.req None None "kind"
              (Data_encoding.constant "freezer"))
            (Data_encoding.req None None "category"
              (Data_encoding.constant "rewards"))
            (Data_encoding.req None None "delegate"
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding))
            (Data_encoding.req None None "cycle" Cycle_repr.encoding))
          (fun function_parameter =>
            match function_parameter with
            | Rewards d l => Some (tt, tt, d, l)
            | _ => None
            end)
          (fun function_parameter =>
            let '(_, _, d, l) := function_parameter in
            Rewards d l);
        Data_encoding.__case_value "Fees" None (Data_encoding.Tag 2)
          (Data_encoding.obj4
            (Data_encoding.req None None "kind"
              (Data_encoding.constant "freezer"))
            (Data_encoding.req None None "category"
              (Data_encoding.constant "fees"))
            (Data_encoding.req None None "delegate"
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding))
            (Data_encoding.req None None "cycle" Cycle_repr.encoding))
          (fun function_parameter =>
            match function_parameter with
            | Fees d l => Some (tt, tt, d, l)
            | _ => None
            end)
          (fun function_parameter =>
            let '(_, _, d, l) := function_parameter in
            Fees d l);
        Data_encoding.__case_value "Deposits" None (Data_encoding.Tag 3)
          (Data_encoding.obj4
            (Data_encoding.req None None "kind"
              (Data_encoding.constant "freezer"))
            (Data_encoding.req None None "category"
              (Data_encoding.constant "deposits"))
            (Data_encoding.req None None "delegate"
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding))
            (Data_encoding.req None None "cycle" Cycle_repr.encoding))
          (fun function_parameter =>
            match function_parameter with
            | Deposits d l => Some (tt, tt, d, l)
            | _ => None
            end)
          (fun function_parameter =>
            let '(_, _, d, l) := function_parameter in
            Deposits d l)
      ]).

Inductive balance_update : Set :=
| Debited : Tez_repr.t -> balance_update
| Credited : Tez_repr.t -> balance_update.

Definition balance_update_encoding : Data_encoding.encoding balance_update :=
  Pervasives.op_atat
    (let arg := Data_encoding.def "operation_metadata.alpha.balance_update" in
    fun eta => arg None None eta)
    (Data_encoding.obj1
      (Data_encoding.req None None "change"
        (Data_encoding.conv
          (fun function_parameter =>
            match function_parameter with
            | Credited v => Tez_repr.to_mutez v
            | Debited v => Int64.neg (Tez_repr.to_mutez v)
            end)
          (Pervasives.op_atat Data_encoding.Json.wrap_error
            (fun v =>
              if
                (|Compare.Int64|).(Compare.S.op_lt) v
                  (* ❌ Constant of type int64 is converted to int *)
                  0 then
                match Tez_repr.of_mutez (Int64.neg v) with
                | Some v => Debited v
                | None => Pervasives.failwith "Qty.of_mutez"
                end
              else
                match Tez_repr.of_mutez v with
                | Some v => Credited v
                | None => Pervasives.failwith "Qty.of_mutez"
                end)) None Data_encoding.__int64_value))).

Definition balance_updates := list (balance * balance_update).

Definition balance_updates_encoding
  : Data_encoding.encoding (list (balance * balance_update)) :=
  Pervasives.op_atat
    (let arg := Data_encoding.def "operation_metadata.alpha.balance_updates" in
    fun eta => arg None None eta)
    (Data_encoding.__list_value None
      (Data_encoding.merge_objs balance_encoding balance_update_encoding)).

Definition cleanup_balance_updates {A : Set}
  (balance_updates : list (A * balance_update)) : list (A * balance_update) :=
  List.filter
    (fun function_parameter =>
      let '(_, Credited update | Debited update) := function_parameter in
      Pervasives.not (Tez_repr.equal update Tez_repr.zero)) balance_updates.

Module frozen_balance.
  Record record := Build {
    deposit : Tez_repr.t;
    fees : Tez_repr.t;
    rewards : Tez_repr.t }.
  Definition with_deposit deposit (r : record) :=
    Build deposit r.(fees) r.(rewards).
  Definition with_fees fees (r : record) :=
    Build r.(deposit) fees r.(rewards).
  Definition with_rewards rewards (r : record) :=
    Build r.(deposit) r.(fees) rewards.
End frozen_balance.
Definition frozen_balance := frozen_balance.record.

Definition frozen_balance_encoding : Data_encoding.encoding frozen_balance :=
  Data_encoding.conv
    (fun function_parameter =>
      let '{|
        frozen_balance.deposit := deposit;
          frozen_balance.fees := fees;
          frozen_balance.rewards := rewards
          |} := function_parameter in
      (deposit, fees, rewards))
    (fun function_parameter =>
      let '(deposit, fees, rewards) := function_parameter in
      {| frozen_balance.deposit := deposit; frozen_balance.fees := fees;
        frozen_balance.rewards := rewards |}) None
    (Data_encoding.obj3
      (Data_encoding.req None None "deposit" Tez_repr.encoding)
      (Data_encoding.req None None "fees" Tez_repr.encoding)
      (Data_encoding.req None None "rewards" Tez_repr.encoding)).

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition link
  (c : Storage.Contract.Balance.context)
  (contract : Storage.Contract.Balance.key)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Error_monad.op_gtgteqquestion (Storage.Contract.Balance.get c contract)
    (fun balance =>
      Error_monad.op_gtgteqquestion
        (Roll_storage.Delegate.add_amount c delegate balance)
        (fun c =>
          Error_monad.op_gtgteq
            (Storage.Contract.Delegated.add
              (c, (Contract_repr.implicit_contract delegate)) contract)
            (fun c => Error_monad.__return c))).

Definition unlink
  (c : Storage.Contract.Balance.context)
  (contract : Storage.Contract.Balance.key)
  : Lwt.t (Error_monad.tzresult Storage.Contract.Balance.context) :=
  Error_monad.op_gtgteqquestion (Storage.Contract.Balance.get c contract)
    (fun balance =>
      Error_monad.op_gtgteqquestion
        (Storage.Contract.Delegate.get_option c contract)
        (fun function_parameter =>
          match function_parameter with
          | None => Error_monad.__return c
          | Some delegate =>
            Error_monad.op_gtgteqquestion
              (Roll_storage.Delegate.remove_amount c delegate balance)
              (fun c =>
                Error_monad.op_gtgteq
                  (Storage.Contract.Delegated.del
                    (c, (Contract_repr.implicit_contract delegate)) contract)
                  (fun c => Error_monad.__return c))
          end)).

Definition known
  (c : Storage.Contract.Manager.context)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.tzresult bool) :=
  Error_monad.op_gtgteqquestion
    (Storage.Contract.Manager.get_option c
      (Contract_repr.implicit_contract delegate))
    (fun function_parameter =>
      match function_parameter with
      | None | Some (Manager_repr.Hash _) => Error_monad.return_false
      | Some (Manager_repr.Public_key _) => Error_monad.return_true
      end).

Definition registered
  (c : Storage.Contract.Delegate.context)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.tzresult bool) :=
  Error_monad.op_gtgteqquestion
    (Storage.Contract.Delegate.get_option c
      (Contract_repr.implicit_contract delegate))
    (fun function_parameter =>
      match function_parameter with
      | Some current_delegate =>
        Pervasives.op_atat Error_monad.__return
          ((|Signature.Public_key_hash|).(S.SPublic_key_hash.equal) delegate
            current_delegate)
      | None => Error_monad.return_false
      end).

Definition init
  (ctxt : Storage.Contract.Manager.context)
  (contract : Storage.Contract.Delegate.key)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Error_monad.op_gtgteqquestion (known ctxt delegate)
    (fun known_delegate =>
      Error_monad.op_gtgteqquestion
        (Error_monad.fail_unless known_delegate extensible_type_value)
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgteqquestion (registered ctxt delegate)
            (fun is_registered =>
              Error_monad.op_gtgteqquestion
                (Error_monad.fail_unless is_registered extensible_type_value)
                (fun function_parameter =>
                  let '_ := function_parameter in
                  Error_monad.op_gtgteqquestion
                    (Storage.Contract.Delegate.init ctxt contract delegate)
                    (fun ctxt => link ctxt contract delegate))))).

Definition get
  : Raw_context.t -> Contract_repr.t ->
  Lwt.t
    (Error_monad.tzresult
      (option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))) :=
  Roll_storage.get_contract_delegate.

Definition set
  (c : Storage.Contract.Balance.context)
  (contract : Storage.Contract.Balance.key)
  (delegate : option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  match delegate with
  | None =>
    let delete (function_parameter : unit)
      : Lwt.t (Error_monad.tzresult Raw_context.t) :=
      let '_ := function_parameter in
      Error_monad.op_gtgteqquestion (unlink c contract)
        (fun c =>
          Error_monad.op_gtgteq (Storage.Contract.Delegate.remove c contract)
            (fun c => Error_monad.__return c)) in
    match Contract_repr.is_implicit contract with
    | Some pkh =>
      Error_monad.op_gtgteqquestion (registered c pkh)
        (fun is_registered =>
          if is_registered then
            Error_monad.fail extensible_type_value
          else
            delete tt)
    | None => delete tt
    end
  | Some delegate =>
    Error_monad.op_gtgteqquestion (known c delegate)
      (fun known_delegate =>
        Error_monad.op_gtgteqquestion (registered c delegate)
          (fun registered_delegate =>
            let self_delegation :=
              match Contract_repr.is_implicit contract with
              | Some pkh =>
                (|Signature.Public_key_hash|).(S.SPublic_key_hash.equal) pkh
                  delegate
              | None => false
              end in
            if
              Pervasives.op_pipepipe (Pervasives.not known_delegate)
                (Pervasives.not
                  (Pervasives.op_pipepipe registered_delegate self_delegation))
              then
              Error_monad.fail extensible_type_value
            else
              Error_monad.op_gtgteqquestion
                (Error_monad.op_gtgteqquestion
                  (Storage.Contract.Delegate.get_option c contract)
                  (fun function_parameter =>
                    match
                      (function_parameter,
                        match function_parameter with
                        | Some current_delegate =>
                          (|Signature.Public_key_hash|).(S.SPublic_key_hash.equal)
                            delegate current_delegate
                        | _ => false
                        end) with
                    | (Some current_delegate, true) =>
                      if self_delegation then
                        Error_monad.op_gtgteqquestion
                          (Roll_storage.Delegate.is_inactive c delegate)
                          (fun function_parameter =>
                            match function_parameter with
                            | true => Error_monad.return_unit
                            | false => Error_monad.fail extensible_type_value
                            end)
                      else
                        Error_monad.fail extensible_type_value
                    | (None | Some _, _) => Error_monad.return_unit
                    end))
                (fun function_parameter =>
                  let '_ := function_parameter in
                  Error_monad.op_gtgteqquestion
                    match Contract_repr.is_implicit contract with
                    | Some pkh =>
                      Error_monad.op_gtgteqquestion (registered c pkh)
                        (fun is_registered =>
                          if
                            Pervasives.op_andand
                              (Pervasives.not self_delegation) is_registered
                            then
                            Error_monad.fail extensible_type_value
                          else
                            Error_monad.return_unit)
                    | None => Error_monad.return_unit
                    end
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      Error_monad.op_gtgteq
                        (Storage.Contract.Balance.mem c contract)
                        (fun __exists =>
                          Error_monad.op_gtgteqquestion
                            (Error_monad.fail_when
                              (Pervasives.op_andand self_delegation
                                (Pervasives.not __exists)) extensible_type_value)
                            (fun function_parameter =>
                              let '_ := function_parameter in
                              Error_monad.op_gtgteqquestion (unlink c contract)
                                (fun c =>
                                  Error_monad.op_gtgteq
                                    (Storage.Contract.Delegate.init_set c
                                      contract delegate)
                                    (fun c =>
                                      Error_monad.op_gtgteqquestion
                                        (link c contract delegate)
                                        (fun c =>
                                          Error_monad.op_gtgteqquestion
                                            (if self_delegation then
                                              Error_monad.op_gtgteq
                                                (Storage.Delegates.add c
                                                  delegate)
                                                (fun c =>
                                                  Error_monad.op_gtgteqquestion
                                                    (Roll_storage.Delegate.set_active
                                                      c delegate)
                                                    (fun c =>
                                                      Error_monad.__return c))
                                            else
                                              Error_monad.__return c)
                                            (fun c => Error_monad.__return c))))))))))
  end.

Definition remove
  (ctxt : Storage.Contract.Balance.context)
  (contract : Storage.Contract.Balance.key)
  : Lwt.t (Error_monad.tzresult Storage.Contract.Balance.context) :=
  unlink ctxt contract.

Definition delegated_contracts
  (ctxt : Raw_context.t)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (list Storage.Contract.Delegated.elt) :=
  let contract := Contract_repr.implicit_contract delegate in
  Storage.Contract.Delegated.elements (ctxt, contract).

Definition get_frozen_deposit
  (ctxt : Raw_context.t) (contract : Contract_repr.t)
  (cycle : Storage.Contract.Frozen_deposits.key)
  : Lwt.t (Error_monad.tzresult Tez_repr.t) :=
  Error_monad.op_gtgteqquestion
    (Storage.Contract.Frozen_deposits.get_option (ctxt, contract) cycle)
    (fun function_parameter =>
      match function_parameter with
      | None => Error_monad.__return Tez_repr.zero
      | Some frozen => Error_monad.__return frozen
      end).

Definition credit_frozen_deposit
  (ctxt : Raw_context.t)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (cycle : Storage.Contract.Frozen_deposits.key) (amount : Tez_repr.t)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let contract := Contract_repr.implicit_contract delegate in
  Error_monad.op_gtgteqquestion (get_frozen_deposit ctxt contract cycle)
    (fun old_amount =>
      Error_monad.op_gtgteqquestion
        (Lwt.__return (Tez_repr.op_plusquestion old_amount amount))
        (fun new_amount =>
          Error_monad.op_gtgteq
            (Storage.Contract.Frozen_deposits.init_set (ctxt, contract) cycle
              new_amount)
            (fun ctxt =>
              Error_monad.op_gtgteq
                (Storage.Delegates_with_frozen_balance.add (ctxt, cycle)
                  delegate) (fun ctxt => Error_monad.__return ctxt)))).

Definition freeze_deposit
  (ctxt : Raw_context.t)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (amount : Tez_repr.t) : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let '{| Level_repr.t.cycle := cycle |} := Level_storage.current ctxt in
  Error_monad.op_gtgteqquestion (Roll_storage.Delegate.set_active ctxt delegate)
    (fun ctxt =>
      let contract := Contract_repr.implicit_contract delegate in
      Error_monad.op_gtgteqquestion (Storage.Contract.Balance.get ctxt contract)
        (fun balance =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Error_monad.record_trace extensible_type_value
                (Tez_repr.op_minusquestion balance amount)))
            (fun new_balance =>
              Error_monad.op_gtgteqquestion
                (Storage.Contract.Balance.set ctxt contract new_balance)
                (fun ctxt => credit_frozen_deposit ctxt delegate cycle amount)))).

Definition get_frozen_fees
  (ctxt : Raw_context.t) (contract : Contract_repr.t)
  (cycle : Storage.Contract.Frozen_fees.key)
  : Lwt.t (Error_monad.tzresult Tez_repr.t) :=
  Error_monad.op_gtgteqquestion
    (Storage.Contract.Frozen_fees.get_option (ctxt, contract) cycle)
    (fun function_parameter =>
      match function_parameter with
      | None => Error_monad.__return Tez_repr.zero
      | Some frozen => Error_monad.__return frozen
      end).

Definition credit_frozen_fees
  (ctxt : Raw_context.t)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (cycle : Storage.Contract.Frozen_fees.key) (amount : Tez_repr.t)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let contract := Contract_repr.implicit_contract delegate in
  Error_monad.op_gtgteqquestion (get_frozen_fees ctxt contract cycle)
    (fun old_amount =>
      Error_monad.op_gtgteqquestion
        (Lwt.__return (Tez_repr.op_plusquestion old_amount amount))
        (fun new_amount =>
          Error_monad.op_gtgteq
            (Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle
              new_amount)
            (fun ctxt =>
              Error_monad.op_gtgteq
                (Storage.Delegates_with_frozen_balance.add (ctxt, cycle)
                  delegate) (fun ctxt => Error_monad.__return ctxt)))).

Definition freeze_fees
  (ctxt : Raw_context.t)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (amount : Tez_repr.t) : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let '{| Level_repr.t.cycle := cycle |} := Level_storage.current ctxt in
  Error_monad.op_gtgteqquestion
    (Roll_storage.Delegate.add_amount ctxt delegate amount)
    (fun ctxt => credit_frozen_fees ctxt delegate cycle amount).

Definition burn_fees
  (ctxt : Raw_context.t)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (cycle : Storage.Contract.Frozen_fees.key) (amount : Tez_repr.t)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let contract := Contract_repr.implicit_contract delegate in
  Error_monad.op_gtgteqquestion (get_frozen_fees ctxt contract cycle)
    (fun old_amount =>
      Error_monad.op_gtgteqquestion
        match Tez_repr.op_minusquestion old_amount amount with
        | Pervasives.Ok new_amount =>
          Error_monad.op_gtgteqquestion
            (Roll_storage.Delegate.remove_amount ctxt delegate amount)
            (fun ctxt => Error_monad.__return (new_amount, ctxt))
        | Pervasives.Error _ =>
          Error_monad.op_gtgteqquestion
            (Roll_storage.Delegate.remove_amount ctxt delegate old_amount)
            (fun ctxt => Error_monad.__return (Tez_repr.zero, ctxt))
        end
        (fun function_parameter =>
          let '(new_amount, ctxt) := function_parameter in
          Error_monad.op_gtgteq
            (Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle
              new_amount) (fun ctxt => Error_monad.__return ctxt))).

Definition get_frozen_rewards
  (ctxt : Raw_context.t) (contract : Contract_repr.t)
  (cycle : Storage.Contract.Frozen_rewards.key)
  : Lwt.t (Error_monad.tzresult Tez_repr.t) :=
  Error_monad.op_gtgteqquestion
    (Storage.Contract.Frozen_rewards.get_option (ctxt, contract) cycle)
    (fun function_parameter =>
      match function_parameter with
      | None => Error_monad.__return Tez_repr.zero
      | Some frozen => Error_monad.__return frozen
      end).

Definition credit_frozen_rewards
  (ctxt : Raw_context.t)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (cycle : Storage.Contract.Frozen_rewards.key) (amount : Tez_repr.t)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let contract := Contract_repr.implicit_contract delegate in
  Error_monad.op_gtgteqquestion (get_frozen_rewards ctxt contract cycle)
    (fun old_amount =>
      Error_monad.op_gtgteqquestion
        (Lwt.__return (Tez_repr.op_plusquestion old_amount amount))
        (fun new_amount =>
          Error_monad.op_gtgteq
            (Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle
              new_amount)
            (fun ctxt =>
              Error_monad.op_gtgteq
                (Storage.Delegates_with_frozen_balance.add (ctxt, cycle)
                  delegate) (fun ctxt => Error_monad.__return ctxt)))).

Definition freeze_rewards
  (ctxt : Raw_context.t)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (amount : Tez_repr.t) : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let '{| Level_repr.t.cycle := cycle |} := Level_storage.current ctxt in
  credit_frozen_rewards ctxt delegate cycle amount.

Definition burn_rewards
  (ctxt : Raw_context.t)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (cycle : Storage.Contract.Frozen_rewards.key) (amount : Tez_repr.t)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let contract := Contract_repr.implicit_contract delegate in
  Error_monad.op_gtgteqquestion (get_frozen_rewards ctxt contract cycle)
    (fun old_amount =>
      let new_amount :=
        match Tez_repr.op_minusquestion old_amount amount with
        | Pervasives.Error _ => Tez_repr.zero
        | Pervasives.Ok new_amount => new_amount
        end in
      Error_monad.op_gtgteq
        (Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle
          new_amount) (fun ctxt => Error_monad.__return ctxt)).

Definition unfreeze
  (ctxt : Raw_context.t)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (cycle : Storage.Contract.Frozen_deposits.key)
  : Lwt.t
    (Error_monad.tzresult (Raw_context.t * list (balance * balance_update))) :=
  let contract := Contract_repr.implicit_contract delegate in
  Error_monad.op_gtgteqquestion (get_frozen_deposit ctxt contract cycle)
    (fun deposit =>
      Error_monad.op_gtgteqquestion (get_frozen_fees ctxt contract cycle)
        (fun fees =>
          Error_monad.op_gtgteqquestion (get_frozen_rewards ctxt contract cycle)
            (fun rewards =>
              Error_monad.op_gtgteqquestion
                (Storage.Contract.Balance.get ctxt contract)
                (fun balance =>
                  Error_monad.op_gtgteqquestion
                    (Lwt.__return (Tez_repr.op_plusquestion deposit fees))
                    (fun unfrozen_amount =>
                      Error_monad.op_gtgteqquestion
                        (Lwt.__return
                          (Tez_repr.op_plusquestion unfrozen_amount rewards))
                        (fun unfrozen_amount =>
                          Error_monad.op_gtgteqquestion
                            (Lwt.__return
                              (Tez_repr.op_plusquestion balance unfrozen_amount))
                            (fun balance =>
                              Error_monad.op_gtgteqquestion
                                (Storage.Contract.Balance.set ctxt contract
                                  balance)
                                (fun ctxt =>
                                  Error_monad.op_gtgteqquestion
                                    (Roll_storage.Delegate.add_amount ctxt
                                      delegate rewards)
                                    (fun ctxt =>
                                      Error_monad.op_gtgteq
                                        (Storage.Contract.Frozen_deposits.remove
                                          (ctxt, contract) cycle)
                                        (fun ctxt =>
                                          Error_monad.op_gtgteq
                                            (Storage.Contract.Frozen_fees.remove
                                              (ctxt, contract) cycle)
                                            (fun ctxt =>
                                              Error_monad.op_gtgteq
                                                (Storage.Contract.Frozen_rewards.remove
                                                  (ctxt, contract) cycle)
                                                (fun ctxt =>
                                                  Error_monad.__return
                                                    (ctxt,
                                                      (cleanup_balance_updates
                                                        [
                                                          ((Deposits delegate
                                                            cycle),
                                                            (Debited
                                                              deposit));
                                                          ((Fees delegate cycle),
                                                            (Debited
                                                              fees));
                                                          ((Rewards delegate
                                                            cycle),
                                                            (Debited
                                                              rewards));
                                                          ((Contract
                                                            (Contract_repr.implicit_contract
                                                              delegate)),
                                                            (Credited
                                                              unfrozen_amount))
                                                        ])))))))))))))).

Definition cycle_end
  (ctxt : Raw_context.context) (last_cycle : Cycle_repr.cycle)
  (unrevealed : list Nonce_storage.unrevealed)
  : Lwt.t
    (Error_monad.tzresult
      (Raw_context.context * list (balance * balance_update) *
        list Storage.Active_delegates_with_rolls.elt)) :=
  let preserved := Constants_storage.preserved_cycles ctxt in
  Error_monad.op_gtgteqquestion
    match Cycle_repr.pred last_cycle with
    | None => Error_monad.__return (ctxt, [])
    | Some revealed_cycle =>
      List.fold_left
        (fun acc =>
          fun u =>
            Error_monad.op_gtgteqquestion acc
              (fun function_parameter =>
                let '(ctxt, balance_updates) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (burn_fees ctxt (Nonce_storage.unrevealed.delegate u)
                    revealed_cycle (Nonce_storage.unrevealed.fees u))
                  (fun ctxt =>
                    Error_monad.op_gtgteqquestion
                      (burn_rewards ctxt (Nonce_storage.unrevealed.delegate u)
                        revealed_cycle (Nonce_storage.unrevealed.rewards u))
                      (fun ctxt =>
                        let bus :=
                          [
                            ((Fees (Nonce_storage.unrevealed.delegate u)
                              revealed_cycle),
                              (Debited
                                (Nonce_storage.unrevealed.fees
                                  u)));
                            ((Rewards (Nonce_storage.unrevealed.delegate u)
                              revealed_cycle),
                              (Debited
                                (Nonce_storage.unrevealed.rewards
                                  u)))
                          ] in
                        Error_monad.__return
                          (ctxt, (Pervasives.op_at bus balance_updates))))))
        (Error_monad.__return (ctxt, [])) unrevealed
    end
    (fun function_parameter =>
      let '(ctxt, balance_updates) := function_parameter in
      match Cycle_repr.sub last_cycle preserved with
      | None => Error_monad.__return (ctxt, balance_updates, [])
      | Some unfrozen_cycle =>
        Error_monad.op_gtgteqquestion
          (Storage.Delegates_with_frozen_balance.fold (ctxt, unfrozen_cycle)
            (Pervasives.Ok (ctxt, balance_updates))
            (fun delegate =>
              fun acc =>
                Error_monad.op_gtgteqquestion (Lwt.__return acc)
                  (fun function_parameter =>
                    let '(ctxt, bus) := function_parameter in
                    Error_monad.op_gtgteqquestion
                      (unfreeze ctxt delegate unfrozen_cycle)
                      (fun function_parameter =>
                        let '(ctxt, balance_updates) := function_parameter in
                        Error_monad.__return
                          (ctxt, (Pervasives.op_at balance_updates bus))))))
          (fun function_parameter =>
            let '(ctxt, balance_updates) := function_parameter in
            Error_monad.op_gtgteq
              (Storage.Delegates_with_frozen_balance.clear
                (ctxt, unfrozen_cycle))
              (fun ctxt =>
                Error_monad.op_gtgteqquestion
                  (Storage.Active_delegates_with_rolls.fold ctxt
                    (Pervasives.Ok (ctxt, []))
                    (fun delegate =>
                      fun acc =>
                        Error_monad.op_gtgteqquestion (Lwt.__return acc)
                          (fun function_parameter =>
                            let '(ctxt, deactivated) := function_parameter in
                            Error_monad.op_gtgteqquestion
                              (Storage.Contract.Delegate_desactivation.get ctxt
                                (Contract_repr.implicit_contract delegate))
                              (fun cycle =>
                                if Cycle_repr.op_lteq cycle last_cycle then
                                  Error_monad.op_gtgteqquestion
                                    (Roll_storage.Delegate.set_inactive ctxt
                                      delegate)
                                    (fun ctxt =>
                                      Error_monad.__return
                                        (ctxt, (cons delegate deactivated)))
                                else
                                  Error_monad.__return (ctxt, deactivated)))))
                  (fun function_parameter =>
                    let '(ctxt, deactivated) := function_parameter in
                    Error_monad.__return (ctxt, balance_updates, deactivated))))
      end).

Definition punish
  (ctxt : Raw_context.t)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (cycle : Storage.Contract.Frozen_deposits.key)
  : Lwt.t (Error_monad.tzresult (Raw_context.t * frozen_balance)) :=
  let contract := Contract_repr.implicit_contract delegate in
  Error_monad.op_gtgteqquestion (get_frozen_deposit ctxt contract cycle)
    (fun deposit =>
      Error_monad.op_gtgteqquestion (get_frozen_fees ctxt contract cycle)
        (fun fees =>
          Error_monad.op_gtgteqquestion (get_frozen_rewards ctxt contract cycle)
            (fun rewards =>
              Error_monad.op_gtgteqquestion
                (Roll_storage.Delegate.remove_amount ctxt delegate deposit)
                (fun ctxt =>
                  Error_monad.op_gtgteqquestion
                    (Roll_storage.Delegate.remove_amount ctxt delegate fees)
                    (fun ctxt =>
                      Error_monad.op_gtgteq
                        (Storage.Contract.Frozen_deposits.remove
                          (ctxt, contract) cycle)
                        (fun ctxt =>
                          Error_monad.op_gtgteq
                            (Storage.Contract.Frozen_fees.remove
                              (ctxt, contract) cycle)
                            (fun ctxt =>
                              Error_monad.op_gtgteq
                                (Storage.Contract.Frozen_rewards.remove
                                  (ctxt, contract) cycle)
                                (fun ctxt =>
                                  Error_monad.__return
                                    (ctxt,
                                      {| frozen_balance.deposit := deposit;
                                        frozen_balance.fees := fees;
                                        frozen_balance.rewards := rewards |}))))))))).

Definition has_frozen_balance
  (ctxt : Raw_context.t)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (cycle : Storage.Contract.Frozen_deposits.key)
  : Lwt.t (Error_monad.tzresult bool) :=
  let contract := Contract_repr.implicit_contract delegate in
  Error_monad.op_gtgteqquestion (get_frozen_deposit ctxt contract cycle)
    (fun deposit =>
      if Tez_repr.op_ltgt deposit Tez_repr.zero then
        Error_monad.return_true
      else
        Error_monad.op_gtgteqquestion (get_frozen_fees ctxt contract cycle)
          (fun fees =>
            if Tez_repr.op_ltgt fees Tez_repr.zero then
              Error_monad.return_true
            else
              Error_monad.op_gtgteqquestion
                (get_frozen_rewards ctxt contract cycle)
                (fun rewards =>
                  Error_monad.__return (Tez_repr.op_ltgt rewards Tez_repr.zero)))).

Definition frozen_balance_by_cycle_encoding
  : Data_encoding.encoding ((|Cycle_repr.Map|).(S.MAP.t) frozen_balance) :=
  Data_encoding.conv (|Cycle_repr.Map|).(S.MAP.bindings)
    (List.fold_left
      (fun m =>
        fun function_parameter =>
          let '(c, b) := function_parameter in
          (|Cycle_repr.Map|).(S.MAP.add) c b m) (|Cycle_repr.Map|).(S.MAP.empty))
    None
    (Data_encoding.__list_value None
      (Data_encoding.merge_objs
        (Data_encoding.obj1
          (Data_encoding.req None None "cycle" Cycle_repr.encoding))
        frozen_balance_encoding)).

Definition empty_frozen_balance : frozen_balance :=
  {| frozen_balance.deposit := Tez_repr.zero;
    frozen_balance.fees := Tez_repr.zero;
    frozen_balance.rewards := Tez_repr.zero |}.

Definition frozen_balance_by_cycle
  (ctxt : Raw_context.t)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t ((|Cycle_repr.Map|).(S.MAP.t) frozen_balance) :=
  let contract := Contract_repr.implicit_contract delegate in
  let map := (|Cycle_repr.Map|).(S.MAP.empty) in
  Error_monad.op_gtgteq
    (Storage.Contract.Frozen_deposits.fold (ctxt, contract) map
      (fun cycle =>
        fun amount =>
          fun map =>
            Lwt.__return
              ((|Cycle_repr.Map|).(S.MAP.add) cycle
                (frozen_balance.with_deposit amount empty_frozen_balance) map)))
    (fun map =>
      Error_monad.op_gtgteq
        (Storage.Contract.Frozen_fees.fold (ctxt, contract) map
          (fun cycle =>
            fun amount =>
              fun map =>
                let balance :=
                  match (|Cycle_repr.Map|).(S.MAP.find_opt) cycle map with
                  | None => empty_frozen_balance
                  | Some balance => balance
                  end in
                Lwt.__return
                  ((|Cycle_repr.Map|).(S.MAP.add) cycle
                    (frozen_balance.with_fees amount balance) map)))
        (fun map =>
          Error_monad.op_gtgteq
            (Storage.Contract.Frozen_rewards.fold (ctxt, contract) map
              (fun cycle =>
                fun amount =>
                  fun map =>
                    let balance :=
                      match (|Cycle_repr.Map|).(S.MAP.find_opt) cycle map with
                      | None => empty_frozen_balance
                      | Some balance => balance
                      end in
                    Lwt.__return
                      ((|Cycle_repr.Map|).(S.MAP.add) cycle
                        (frozen_balance.with_rewards amount balance) map)))
            (fun map => Lwt.__return map))).

Definition frozen_balance
  (ctxt : Raw_context.t)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Pervasives.result Tez_repr.t (list Error_monad.__error)) :=
  let contract := Contract_repr.implicit_contract delegate in
  let balance := Pervasives.Ok Tez_repr.zero in
  Error_monad.op_gtgteq
    (Storage.Contract.Frozen_deposits.fold (ctxt, contract) balance
      (fun _cycle =>
        fun amount =>
          fun acc =>
            Error_monad.op_gtgteqquestion (Lwt.__return acc)
              (fun acc => Lwt.__return (Tez_repr.op_plusquestion acc amount))))
    (fun balance =>
      Error_monad.op_gtgteq
        (Storage.Contract.Frozen_fees.fold (ctxt, contract) balance
          (fun _cycle =>
            fun amount =>
              fun acc =>
                Error_monad.op_gtgteqquestion (Lwt.__return acc)
                  (fun acc => Lwt.__return (Tez_repr.op_plusquestion acc amount))))
        (fun balance =>
          Error_monad.op_gtgteq
            (Storage.Contract.Frozen_rewards.fold (ctxt, contract) balance
              (fun _cycle =>
                fun amount =>
                  fun acc =>
                    Error_monad.op_gtgteqquestion (Lwt.__return acc)
                      (fun acc =>
                        Lwt.__return (Tez_repr.op_plusquestion acc amount))))
            (fun balance => Lwt.__return balance))).

Definition full_balance
  (ctxt : Raw_context.t)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.tzresult Tez_repr.t) :=
  let contract := Contract_repr.implicit_contract delegate in
  Error_monad.op_gtgteqquestion (frozen_balance ctxt delegate)
    (fun frozen_balance =>
      Error_monad.op_gtgteqquestion (Storage.Contract.Balance.get ctxt contract)
        (fun balance =>
          Lwt.__return (Tez_repr.op_plusquestion frozen_balance balance))).

Definition deactivated
  : Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult bool) := Roll_storage.Delegate.is_inactive.

Definition grace_period
  (ctxt : Storage.Contract.Delegate_desactivation.context)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.tzresult Storage.Contract.Delegate_desactivation.value) :=
  let contract := Contract_repr.implicit_contract delegate in
  Storage.Contract.Delegate_desactivation.get ctxt contract.

Definition staking_balance
  (ctxt : Raw_context.context)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.tzresult Tez_repr.t) :=
  let token_per_rolls := Constants_storage.tokens_per_roll ctxt in
  Error_monad.op_gtgteqquestion (Roll_storage.get_rolls ctxt delegate)
    (fun rolls =>
      Error_monad.op_gtgteqquestion (Roll_storage.get_change ctxt delegate)
        (fun change =>
          let rolls := Int64.of_int (List.length rolls) in
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Tez_repr.op_starquestion token_per_rolls rolls))
            (fun balance =>
              Lwt.__return (Tez_repr.op_plusquestion balance change)))).

Definition delegated_balance
  (ctxt : Raw_context.context)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.tzresult Tez_repr.t) :=
  let contract := Contract_repr.implicit_contract delegate in
  Error_monad.op_gtgteqquestion (staking_balance ctxt delegate)
    (fun staking_balance =>
      Error_monad.op_gtgteq (Storage.Contract.Balance.get ctxt contract)
        (fun self_staking_balance =>
          Error_monad.op_gtgteq
            (Storage.Contract.Frozen_deposits.fold (ctxt, contract)
              self_staking_balance
              (fun _cycle =>
                fun amount =>
                  fun acc =>
                    Error_monad.op_gtgteqquestion (Lwt.__return acc)
                      (fun acc =>
                        Lwt.__return (Tez_repr.op_plusquestion acc amount))))
            (fun self_staking_balance =>
              Error_monad.op_gtgteqquestion
                (Storage.Contract.Frozen_fees.fold (ctxt, contract)
                  self_staking_balance
                  (fun _cycle =>
                    fun amount =>
                      fun acc =>
                        Error_monad.op_gtgteqquestion (Lwt.__return acc)
                          (fun acc =>
                            Lwt.__return (Tez_repr.op_plusquestion acc amount))))
                (fun self_staking_balance =>
                  Lwt.__return
                    (Tez_repr.op_minusquestion staking_balance
                      self_staking_balance))))).

Definition fold {A : Set}
  : Storage.Delegates.context -> A -> (Storage.Delegates.elt -> A -> Lwt.t A) ->
  Lwt.t A := Storage.Delegates.fold.

Definition __list_value
  : Storage.Delegates.context -> Lwt.t (list Storage.Delegates.elt) :=
  Storage.Delegates.elements.

Delegate_storage_mli

  • OCaml size: 191 lines
  • Coq size: 151 lines (-21% compared to OCaml)
delegate_storage.mli 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Places where tezzies can be found in the ledger's state. *)
type balance =
  | Contract of Contract_repr.t
  | Rewards of Signature.Public_key_hash.t * Cycle_repr.t
  | Fees of Signature.Public_key_hash.t * Cycle_repr.t
  | Deposits of Signature.Public_key_hash.t * Cycle_repr.t

(** A credit or debit of tezzies to a balance. *)
type balance_update = Debited of Tez_repr.t | Credited of Tez_repr.t

(** A list of balance updates. Duplicates may happen. *)
type balance_updates = (balance * balance_update) list

val balance_updates_encoding : balance_updates Data_encoding.t

(** Remove zero-valued balances from a list of updates. *)
val cleanup_balance_updates : balance_updates -> balance_updates

type frozen_balance = {
  deposit : Tez_repr.t;
  fees : Tez_repr.t;
  rewards : Tez_repr.t;
}

(** Allow to register a delegate when creating an account. *)
val init :
  Raw_context.t ->
  Contract_repr.t ->
  Signature.Public_key_hash.t ->
  Raw_context.t tzresult Lwt.t

(** Cleanup delegation when deleting a contract. *)
val remove : Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t

(** Reading the current delegate of a contract. *)
val get :
  Raw_context.t ->
  Contract_repr.t ->
  Signature.Public_key_hash.t option tzresult Lwt.t

val registered :
  Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t

(** Updating the delegate of a contract.

    When calling this function on an "implicit contract" and setting
    the delegate to the contract manager registers it as a delegate. One
    cannot unregister a delegate for now. The associate contract is now
    'undeletable'. *)
val set :
  Raw_context.t ->
  Contract_repr.t ->
  Signature.Public_key_hash.t option ->
  Raw_context.t tzresult Lwt.t

type error +=
  | No_deletion of Signature.Public_key_hash.t (* `Permanent *)
  | Active_delegate (* `Temporary *)
  | Current_delegate (* `Temporary *)
  | Empty_delegate_account of Signature.Public_key_hash.t (* `Temporary *)
  | Balance_too_low_for_deposit of {
      delegate : Signature.Public_key_hash.t;
      deposit : Tez_repr.t;
      balance : Tez_repr.t;
    }

(* `Temporary *)

(** Iterate on all registered delegates. *)
val fold :
  Raw_context.t ->
  init:'a ->
  f:(Signature.Public_key_hash.t -> 'a -> 'a Lwt.t) ->
  'a Lwt.t

(** List all registered delegates. *)
val list : Raw_context.t -> Signature.Public_key_hash.t list Lwt.t

(** Various functions to 'freeze' tokens.  A frozen 'deposit' keeps its
    associated rolls. When frozen, 'fees' may trigger new rolls
    allocation. Rewards won't trigger new rolls allocation until
    unfrozen. *)
val freeze_deposit :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Tez_repr.t ->
  Raw_context.t tzresult Lwt.t

val freeze_fees :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Tez_repr.t ->
  Raw_context.t tzresult Lwt.t

val freeze_rewards :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Tez_repr.t ->
  Raw_context.t tzresult Lwt.t

(** Trigger the context maintenance at the end of cycle 'n', i.e.:
    unfreeze deposit/fees/rewards from 'n - preserved_cycle' ; punish the
    provided unrevealed seeds (tipically seed from cycle 'n - 1').
    Returns a list of account with the amount that was unfrozen for each
    and the list of deactivated delegates. *)
val cycle_end :
  Raw_context.t ->
  Cycle_repr.t ->
  Nonce_storage.unrevealed list ->
  (Raw_context.t * balance_updates * Signature.Public_key_hash.t list) tzresult
  Lwt.t

(** Burn all then frozen deposit/fees/rewards for a delegate at a given
    cycle. Returns the burned amounts. *)
val punish :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Cycle_repr.t ->
  (Raw_context.t * frozen_balance) tzresult Lwt.t

(** Has the given key some frozen tokens in its implicit contract? *)
val has_frozen_balance :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Cycle_repr.t ->
  bool tzresult Lwt.t

(** Returns the amount of frozen deposit, fees and rewards associated
    to a given delegate. *)
val frozen_balance :
  Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t

val frozen_balance_encoding : frozen_balance Data_encoding.t

val frozen_balance_by_cycle_encoding :
  frozen_balance Cycle_repr.Map.t Data_encoding.t

(** Returns the amount of frozen deposit, fees and rewards associated
    to a given delegate, indexed by the cycle by which at the end the
    balance will be unfrozen. *)
val frozen_balance_by_cycle :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  frozen_balance Cycle_repr.Map.t Lwt.t

(** Returns the full 'balance' of the implicit contract associated to
    a given key, i.e. the sum of the spendable balance and of the
    frozen balance. *)
val full_balance :
  Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t

val staking_balance :
  Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t

(** Returns the list of contracts (implicit or originated) that delegated towards a given delegate *)
val delegated_contracts :
  Raw_context.t -> Signature.Public_key_hash.t -> Contract_repr.t list Lwt.t

val delegated_balance :
  Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t

val deactivated :
  Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t

val grace_period :
  Raw_context.t -> Signature.Public_key_hash.t -> Cycle_repr.t tzresult Lwt.t
Delegate_storage_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Contract_repr.
Require Tezos.Cycle_repr.
Require Tezos.Nonce_storage.
Require Tezos.Raw_context.
Require Tezos.Tez_repr.

Inductive balance : Set :=
| Contract : Contract_repr.t -> balance
| Rewards :
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> Cycle_repr.t ->
  balance
| Fees :
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> Cycle_repr.t ->
  balance
| Deposits :
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> Cycle_repr.t ->
  balance.

Inductive balance_update : Set :=
| Debited : Tez_repr.t -> balance_update
| Credited : Tez_repr.t -> balance_update.

Definition balance_updates := list (balance * balance_update).

Parameter balance_updates_encoding : Data_encoding.t balance_updates.

Parameter cleanup_balance_updates : balance_updates -> balance_updates.

Module frozen_balance.
  Record record := Build {
    deposit : Tez_repr.t;
    fees : Tez_repr.t;
    rewards : Tez_repr.t }.
  Definition with_deposit deposit (r : record) :=
    Build deposit r.(fees) r.(rewards).
  Definition with_fees fees (r : record) :=
    Build r.(deposit) fees r.(rewards).
  Definition with_rewards rewards (r : record) :=
    Build r.(deposit) r.(fees) rewards.
End frozen_balance.
Definition frozen_balance := frozen_balance.record.

Parameter init :
  Raw_context.t -> Contract_repr.t ->
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter remove :
  Raw_context.t -> Contract_repr.t -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter get :
  Raw_context.t -> Contract_repr.t ->
  Lwt.t
    (Error_monad.tzresult
      (option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))).

Parameter registered :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult bool).

Parameter set :
  Raw_context.t -> Contract_repr.t ->
  option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult Raw_context.t).

(* extensible_type error *)

Parameter fold : forall {a : Set},
  Raw_context.t -> a ->
  ((|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> a -> Lwt.t a) ->
  Lwt.t a.

Parameter __list_value :
  Raw_context.t ->
  Lwt.t (list (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)).

Parameter freeze_deposit :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Tez_repr.t -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter freeze_fees :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Tez_repr.t -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter freeze_rewards :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Tez_repr.t -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter cycle_end :
  Raw_context.t -> Cycle_repr.t -> list Nonce_storage.unrevealed ->
  Lwt.t
    (Error_monad.tzresult
      (Raw_context.t * balance_updates *
        list (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))).

Parameter punish :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Cycle_repr.t -> Lwt.t (Error_monad.tzresult (Raw_context.t * frozen_balance)).

Parameter has_frozen_balance :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Cycle_repr.t -> Lwt.t (Error_monad.tzresult bool).

Parameter frozen_balance :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult Tez_repr.t).

Parameter frozen_balance_encoding : Data_encoding.t frozen_balance.

Parameter frozen_balance_by_cycle_encoding :
  Data_encoding.t ((|Cycle_repr.Map|).(S.MAP.t) frozen_balance).

Parameter frozen_balance_by_cycle :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t ((|Cycle_repr.Map|).(S.MAP.t) frozen_balance).

Parameter full_balance :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult Tez_repr.t).

Parameter staking_balance :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult Tez_repr.t).

Parameter delegated_contracts :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (list Contract_repr.t).

Parameter delegated_balance :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult Tez_repr.t).

Parameter deactivated :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult bool).

Parameter grace_period :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult Cycle_repr.t).

Fees_storage

  • OCaml size: 121 lines
  • Coq size: 105 lines (-14% compared to OCaml)
fees_storage.ml 7 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += Cannot_pay_storage_fee (* `Temporary *)

type error += Operation_quota_exceeded (* `Temporary *)

type error += Storage_limit_too_high (* `Permanent *)

let () =
  let open Data_encoding in
  register_error_kind
    `Temporary
    ~id:"contract.cannot_pay_storage_fee"
    ~title:"Cannot pay storage fee"
    ~description:"The storage fee is higher than the contract balance"
    ~pp:(fun ppf () -> Format.fprintf ppf "Cannot pay storage storage fee")
    Data_encoding.empty
    (function Cannot_pay_storage_fee -> Some () | _ -> None)
    (fun () -> Cannot_pay_storage_fee) ;
  register_error_kind
    `Temporary
    ~id:"storage_exhausted.operation"
    ~title:"Storage quota exceeded for the operation"
    ~description:
      "A script or one of its callee wrote more bytes than the operation said \
       it would"
    Data_encoding.empty
    (function Operation_quota_exceeded -> Some () | _ -> None)
    (fun () -> Operation_quota_exceeded) ;
  register_error_kind
    `Permanent
    ~id:"storage_limit_too_high"
    ~title:"Storage limit out of protocol hard bounds"
    ~description:"A transaction tried to exceed the hard limit on storage"
    empty
    (function Storage_limit_too_high -> Some () | _ -> None)
    (fun () -> Storage_limit_too_high)

let origination_burn c =
  let origination_size = Constants_storage.origination_size c in
  let cost_per_byte = Constants_storage.cost_per_byte c in
  (* the origination burn, measured in bytes *)
  Lwt.return Tez_repr.(cost_per_byte *? Int64.of_int origination_size)
  >>=? fun to_be_paid ->
  return (Raw_context.update_allocated_contracts_count c, to_be_paid)

let record_paid_storage_space c contract =
  Contract_storage.used_storage_space c contract
  >>=? fun size ->
  Contract_storage.set_paid_storage_space_and_return_fees_to_pay
    c
    contract
    size
  >>=? fun (to_be_paid, c) ->
  let c = Raw_context.update_storage_space_to_pay c to_be_paid in
  let cost_per_byte = Constants_storage.cost_per_byte c in
  Lwt.return Tez_repr.(cost_per_byte *? Z.to_int64 to_be_paid)
  >>=? fun to_burn -> return (c, size, to_be_paid, to_burn)

let burn_storage_fees c ~storage_limit ~payer =
  let origination_size = Constants_storage.origination_size c in
  let (c, storage_space_to_pay, allocated_contracts) =
    Raw_context.clear_storage_space_to_pay c
  in
  let storage_space_for_allocated_contracts =
    Z.mul (Z.of_int allocated_contracts) (Z.of_int origination_size)
  in
  let consumed =
    Z.add storage_space_to_pay storage_space_for_allocated_contracts
  in
  let remaining = Z.sub storage_limit consumed in
  if Compare.Z.(remaining < Z.zero) then fail Operation_quota_exceeded
  else
    let cost_per_byte = Constants_storage.cost_per_byte c in
    Lwt.return Tez_repr.(cost_per_byte *? Z.to_int64 consumed)
    >>=? fun to_burn ->
    (* Burning the fees... *)
    if Tez_repr.(to_burn = Tez_repr.zero) then
      (* If the payer was was deleted by transfering all its balance, and no space was used,
         burning zero would fail *)
      return c
    else
      trace
        Cannot_pay_storage_fee
        ( Contract_storage.must_exist c payer
        >>=? fun () -> Contract_storage.spend c payer to_burn )
      >>=? fun c -> return c

let check_storage_limit c ~storage_limit =
  if
    Compare.Z.(
      storage_limit
      > (Raw_context.constants c).hard_storage_limit_per_operation)
    || Compare.Z.(storage_limit < Z.zero)
  then error Storage_limit_too_high
  else ok ()

let start_counting_storage_fees c = Raw_context.init_storage_space_to_pay c
Fees_storage.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Constants_repr.
Require Tezos.Constants_storage.
Require Tezos.Contract_repr.
Require Tezos.Contract_storage.
Require Tezos.Raw_context.
Require Tezos.Tez_repr.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition origination_burn (c : Raw_context.context)
  : Lwt.t (Error_monad.tzresult (Raw_context.t * Tez_repr.t)) :=
  let origination_size := Constants_storage.origination_size c in
  let cost_per_byte := Constants_storage.cost_per_byte c in
  Error_monad.op_gtgteqquestion
    (Lwt.__return
      (Tez_repr.op_starquestion cost_per_byte (Int64.of_int origination_size)))
    (fun to_be_paid =>
      Error_monad.__return
        ((Raw_context.update_allocated_contracts_count c), to_be_paid)).

Definition record_paid_storage_space
  (c : Raw_context.t) (contract : Contract_repr.t)
  : Lwt.t (Error_monad.tzresult (Raw_context.t * Z.t * Z.t * Tez_repr.t)) :=
  Error_monad.op_gtgteqquestion (Contract_storage.used_storage_space c contract)
    (fun size =>
      Error_monad.op_gtgteqquestion
        (Contract_storage.set_paid_storage_space_and_return_fees_to_pay c
          contract size)
        (fun function_parameter =>
          let '(to_be_paid, c) := function_parameter in
          let c := Raw_context.update_storage_space_to_pay c to_be_paid in
          let cost_per_byte := Constants_storage.cost_per_byte c in
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Tez_repr.op_starquestion cost_per_byte (Z.to_int64 to_be_paid)))
            (fun to_burn => Error_monad.__return (c, size, to_be_paid, to_burn)))).

Definition burn_storage_fees
  (c : Raw_context.context) (storage_limit : Z.t) (payer : Contract_repr.t)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let origination_size := Constants_storage.origination_size c in
  let '(c, storage_space_to_pay, allocated_contracts) :=
    Raw_context.clear_storage_space_to_pay c in
  let storage_space_for_allocated_contracts :=
    Z.mul (Z.of_int allocated_contracts) (Z.of_int origination_size) in
  let consumed :=
    Z.add storage_space_to_pay storage_space_for_allocated_contracts in
  let remaining := Z.sub storage_limit consumed in
  if (|Compare.Z|).(Compare.S.op_lt) remaining Z.zero then
    Error_monad.fail extensible_type_value
  else
    let cost_per_byte := Constants_storage.cost_per_byte c in
    Error_monad.op_gtgteqquestion
      (Lwt.__return
        (Tez_repr.op_starquestion cost_per_byte (Z.to_int64 consumed)))
      (fun to_burn =>
        if Tez_repr.op_eq to_burn Tez_repr.zero then
          Error_monad.__return c
        else
          Error_monad.op_gtgteqquestion
            (Error_monad.trace extensible_type_value
              (Error_monad.op_gtgteqquestion
                (Contract_storage.must_exist c payer)
                (fun function_parameter =>
                  let '_ := function_parameter in
                  Contract_storage.spend c payer to_burn)))
            (fun c => Error_monad.__return c)).

Definition check_storage_limit
  (c : Raw_context.context) (storage_limit : (|Compare.Z|).(Compare.S.t))
  : Error_monad.tzresult unit :=
  if
    Pervasives.op_pipepipe
      ((|Compare.Z|).(Compare.S.op_gt) storage_limit
        (Constants_repr.parametric.hard_storage_limit_per_operation
          (Raw_context.constants c)))
      ((|Compare.Z|).(Compare.S.op_lt) storage_limit Z.zero) then
    Error_monad.__error_value extensible_type_value
  else
    Error_monad.ok tt.

Definition start_counting_storage_fees (c : Raw_context.t) : Raw_context.t :=
  Raw_context.init_storage_space_to_pay c.

Fees_storage_mli

  • OCaml size: 50 lines
  • Coq size: 37 lines (-26% compared to OCaml)
fees_storage.mli 3 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += Cannot_pay_storage_fee (* `Temporary *)

type error += Operation_quota_exceeded (* `Temporary *)

type error += Storage_limit_too_high (* `Permanent *)

(** Does not burn, only adds the burn to storage space to be paid *)
val origination_burn :
  Raw_context.t -> (Raw_context.t * Tez_repr.t) tzresult Lwt.t

(** The returned Tez quantity is for logging purpose only *)
val record_paid_storage_space :
  Raw_context.t ->
  Contract_repr.t ->
  (Raw_context.t * Z.t * Z.t * Tez_repr.t) tzresult Lwt.t

val check_storage_limit : Raw_context.t -> storage_limit:Z.t -> unit tzresult

val start_counting_storage_fees : Raw_context.t -> Raw_context.t

val burn_storage_fees :
  Raw_context.t ->
  storage_limit:Z.t ->
  payer:Contract_repr.t ->
  Raw_context.t tzresult Lwt.t
Fees_storage_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Contract_repr.
Require Tezos.Raw_context.
Require Tezos.Tez_repr.

(* extensible_type error *)

(* extensible_type error *)

(* extensible_type error *)

Parameter origination_burn :
  Raw_context.t -> Lwt.t (Error_monad.tzresult (Raw_context.t * Tez_repr.t)).

Parameter record_paid_storage_space :
  Raw_context.t -> Contract_repr.t ->
  Lwt.t (Error_monad.tzresult (Raw_context.t * Z.t * Z.t * Tez_repr.t)).

Parameter check_storage_limit :
  Raw_context.t -> Z.t -> Error_monad.tzresult unit.

Parameter start_counting_storage_fees : Raw_context.t -> Raw_context.t.

Parameter burn_storage_fees :
  Raw_context.t -> Z.t -> Contract_repr.t ->
  Lwt.t (Error_monad.tzresult Raw_context.t).

Fitness_repr

  • OCaml size: 62 lines
  • Coq size: 62 lines (+0% compared to OCaml)
fitness_repr.ml 5 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += Invalid_fitness (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"invalid_fitness"
    ~title:"Invalid fitness"
    ~description:"Fitness representation should be exactly 8 bytes long."
    ~pp:(fun ppf () -> Format.fprintf ppf "Invalid fitness")
    Data_encoding.empty
    (function Invalid_fitness -> Some () | _ -> None)
    (fun () -> Invalid_fitness)

let int64_to_bytes i =
  let b = MBytes.create 8 in
  MBytes.set_int64 b 0 i ; b

let int64_of_bytes b =
  if Compare.Int.(MBytes.length b <> 8) then error Invalid_fitness
  else ok (MBytes.get_int64 b 0)

let from_int64 fitness =
  [MBytes.of_string Constants_repr.version_number; int64_to_bytes fitness]

let to_int64 = function
  | [version; fitness]
    when Compare.String.(
           MBytes.to_string version = Constants_repr.version_number) ->
      int64_of_bytes fitness
  | [version; _fitness (* ignored since higher version takes priority *)]
    when Compare.String.(
           MBytes.to_string version = Constants_repr.version_number_004) ->
      ok 0L
  | [] ->
      ok 0L
  | _ ->
      error Invalid_fitness
Fitness_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Constants_repr.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition int64_to_bytes (i : int64) : MBytes.t :=
  let b := MBytes.create 8 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  b.

Definition int64_of_bytes (b : MBytes.t) : Error_monad.tzresult int64 :=
  if (|Compare.Int|).(Compare.S.op_ltgt) (MBytes.length b) 8 then
    Error_monad.__error_value extensible_type_value
  else
    Error_monad.ok (MBytes.get_int64 b 0).

Definition from_int64 (fitness : int64) : list MBytes.t :=
  [ MBytes.of_string Constants_repr.version_number; int64_to_bytes fitness ].

Definition to_int64 (function_parameter : list MBytes.t)
  : Error_monad.tzresult int64 :=
  match
    (function_parameter,
      match function_parameter with
      | cons version (cons fitness []) =>
        (|Compare.String|).(Compare.S.op_eq) (MBytes.to_string version)
          Constants_repr.version_number
      | _ => false
      end,
      match function_parameter with
      | cons version (cons _fitness []) =>
        (|Compare.String|).(Compare.S.op_eq) (MBytes.to_string version)
          Constants_repr.version_number_004
      | _ => false
      end) with
  | (cons version (cons fitness []), true, _) => int64_of_bytes fitness
  | (cons version (cons _fitness []), _, true) =>
    Error_monad.ok
      (* ❌ Constant of type int64 is converted to int *)
      0
  | ([], _, _) =>
    Error_monad.ok
      (* ❌ Constant of type int64 is converted to int *)
      0
  | (_, _, _) => Error_monad.__error_value extensible_type_value
  end.

Fitness_storage

  • OCaml size: 30 lines
  • Coq size: 27 lines (-10% compared to OCaml)
fitness_storage.ml success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let current = Raw_context.current_fitness

let increase ?(gap = 1) ctxt =
  let fitness = current ctxt in
  Raw_context.set_current_fitness ctxt (Int64.add (Int64.of_int gap) fitness)
Fitness_storage.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Raw_context.

Definition current : Raw_context.context -> Int64.t :=
  Raw_context.current_fitness.

Definition increase (op_staroptstar : option Z)
  : Raw_context.context -> Raw_context.t :=
  let gap :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 1
    end in
  fun ctxt =>
    let fitness := current ctxt in
    Raw_context.set_current_fitness ctxt (Int64.add (Int64.of_int gap) fitness).

Gas_limit_repr

  • OCaml size: 260 lines
  • Coq size: 307 lines (+18% compared to OCaml)
gas_limit_repr.ml 5 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Unaccounted | Limited of {remaining : Z.t}

type internal_gas = Z.t

type cost = {
  allocations : Z.t;
  steps : Z.t;
  reads : Z.t;
  writes : Z.t;
  bytes_read : Z.t;
  bytes_written : Z.t;
}

let encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Limited"
        z
        (function Limited {remaining} -> Some remaining | _ -> None)
        (fun remaining -> Limited {remaining});
      case
        (Tag 1)
        ~title:"Unaccounted"
        (constant "unaccounted")
        (function Unaccounted -> Some () | _ -> None)
        (fun () -> Unaccounted) ]

let pp ppf = function
  | Unaccounted ->
      Format.fprintf ppf "unaccounted"
  | Limited {remaining} ->
      Format.fprintf ppf "%s units remaining" (Z.to_string remaining)

let cost_encoding =
  let open Data_encoding in
  conv
    (fun {allocations; steps; reads; writes; bytes_read; bytes_written} ->
      (allocations, steps, reads, writes, bytes_read, bytes_written))
    (fun (allocations, steps, reads, writes, bytes_read, bytes_written) ->
      {allocations; steps; reads; writes; bytes_read; bytes_written})
    (obj6
       (req "allocations" z)
       (req "steps" z)
       (req "reads" z)
       (req "writes" z)
       (req "bytes_read" z)
       (req "bytes_written" z))

let pp_cost ppf {allocations; steps; reads; writes; bytes_read; bytes_written}
    =
  Format.fprintf
    ppf
    "(steps: %s, allocs: %s, reads: %s (%s bytes), writes: %s (%s bytes))"
    (Z.to_string steps)
    (Z.to_string allocations)
    (Z.to_string reads)
    (Z.to_string bytes_read)
    (Z.to_string writes)
    (Z.to_string bytes_written)

type error += Block_quota_exceeded (* `Temporary *)

type error += Operation_quota_exceeded (* `Temporary *)

let allocation_weight = Z.of_int 2

let step_weight = Z.of_int 1

let read_base_weight = Z.of_int 100

let write_base_weight = Z.of_int 160

let byte_read_weight = Z.of_int 10

let byte_written_weight = Z.of_int 15

let rescaling_bits = 7

let rescaling_mask = Z.sub (Z.shift_left Z.one rescaling_bits) Z.one

let scale (z : Z.t) = Z.shift_left z rescaling_bits

let rescale (z : Z.t) = Z.shift_right z rescaling_bits

let cost_to_internal_gas (cost : cost) : internal_gas =
  Z.add
    (Z.add
       (Z.mul cost.allocations allocation_weight)
       (Z.mul cost.steps step_weight))
    (Z.add
       (Z.add
          (Z.mul cost.reads read_base_weight)
          (Z.mul cost.writes write_base_weight))
       (Z.add
          (Z.mul cost.bytes_read byte_read_weight)
          (Z.mul cost.bytes_written byte_written_weight)))

let internal_gas_to_gas internal_gas : Z.t * internal_gas =
  let gas = rescale internal_gas in
  let rest = Z.logand internal_gas rescaling_mask in
  (gas, rest)

let consume block_gas operation_gas internal_gas cost =
  match operation_gas with
  | Unaccounted ->
      ok (block_gas, Unaccounted, internal_gas)
  | Limited {remaining} ->
      let cost_internal_gas = cost_to_internal_gas cost in
      let total_internal_gas = Z.add cost_internal_gas internal_gas in
      let (gas, rest) = internal_gas_to_gas total_internal_gas in
      if Compare.Z.(gas > Z.zero) then
        let remaining = Z.sub remaining gas in
        let block_remaining = Z.sub block_gas gas in
        if Compare.Z.(remaining < Z.zero) then error Operation_quota_exceeded
        else if Compare.Z.(block_remaining < Z.zero) then
          error Block_quota_exceeded
        else ok (block_remaining, Limited {remaining}, rest)
      else ok (block_gas, operation_gas, total_internal_gas)

let check_enough block_gas operation_gas internal_gas cost =
  consume block_gas operation_gas internal_gas cost
  >|? fun (_block_remainig, _remaining, _internal_gas) -> ()

let internal_gas_zero : internal_gas = Z.zero

let alloc_cost n =
  {
    allocations = scale (Z.of_int (n + 1));
    steps = Z.zero;
    reads = Z.zero;
    writes = Z.zero;
    bytes_read = Z.zero;
    bytes_written = Z.zero;
  }

let alloc_bytes_cost n = alloc_cost ((n + 7) / 8)

let alloc_bits_cost n = alloc_cost ((n + 63) / 64)

let atomic_step_cost n =
  {
    allocations = Z.zero;
    steps = Z.of_int (2 * n);
    reads = Z.zero;
    writes = Z.zero;
    bytes_read = Z.zero;
    bytes_written = Z.zero;
  }

let step_cost n =
  {
    allocations = Z.zero;
    steps = scale (Z.of_int n);
    reads = Z.zero;
    writes = Z.zero;
    bytes_read = Z.zero;
    bytes_written = Z.zero;
  }

let free =
  {
    allocations = Z.zero;
    steps = Z.zero;
    reads = Z.zero;
    writes = Z.zero;
    bytes_read = Z.zero;
    bytes_written = Z.zero;
  }

let read_bytes_cost n =
  {
    allocations = Z.zero;
    steps = Z.zero;
    reads = scale Z.one;
    writes = Z.zero;
    bytes_read = scale n;
    bytes_written = Z.zero;
  }

let write_bytes_cost n =
  {
    allocations = Z.zero;
    steps = Z.zero;
    reads = Z.zero;
    writes = Z.one;
    bytes_read = Z.zero;
    bytes_written = scale n;
  }

let ( +@ ) x y =
  {
    allocations = Z.add x.allocations y.allocations;
    steps = Z.add x.steps y.steps;
    reads = Z.add x.reads y.reads;
    writes = Z.add x.writes y.writes;
    bytes_read = Z.add x.bytes_read y.bytes_read;
    bytes_written = Z.add x.bytes_written y.bytes_written;
  }

let ( *@ ) x y =
  {
    allocations = Z.mul (Z.of_int x) y.allocations;
    steps = Z.mul (Z.of_int x) y.steps;
    reads = Z.mul (Z.of_int x) y.reads;
    writes = Z.mul (Z.of_int x) y.writes;
    bytes_read = Z.mul (Z.of_int x) y.bytes_read;
    bytes_written = Z.mul (Z.of_int x) y.bytes_written;
  }

let alloc_mbytes_cost n = alloc_cost 12 +@ alloc_bytes_cost n

let () =
  let open Data_encoding in
  register_error_kind
    `Temporary
    ~id:"gas_exhausted.operation"
    ~title:"Gas quota exceeded for the operation"
    ~description:
      "A script or one of its callee took more time than the operation said \
       it would"
    empty
    (function Operation_quota_exceeded -> Some () | _ -> None)
    (fun () -> Operation_quota_exceeded) ;
  register_error_kind
    `Temporary
    ~id:"gas_exhausted.block"
    ~title:"Gas quota exceeded for the block"
    ~description:
      "The sum of gas consumed by all the operations in the block exceeds the \
       hard gas limit per block"
    empty
    (function Block_quota_exceeded -> Some () | _ -> None)
    (fun () -> Block_quota_exceeded)
Gas_limit_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Module t.
  Module Limited.
    Record record {remaining : Set} := {
      remaining : remaining }.
    Arguments record : clear implicits.
  End Limited.
  Definition Limited_skeleton := Limited.record.
End t.

Reserved Notation "'t.Limited".

Inductive t : Set :=
| Unaccounted : t
| Limited : 't.Limited -> t

where "'t.Limited" := (t.Limited_skeleton Z.t).

Module ConstructorRecordNotations_t.
  Module t.
    Definition Limited := 't.Limited.
  End t.
End ConstructorRecordNotations_t.
Import ConstructorRecordNotations_t.

Definition internal_gas := Z.t.

Module cost.
  Record record := Build {
    allocations : Z.t;
    steps : Z.t;
    reads : Z.t;
    writes : Z.t;
    bytes_read : Z.t;
    bytes_written : Z.t }.
  Definition with_allocations allocations (r : record) :=
    Build allocations r.(steps) r.(reads) r.(writes) r.(bytes_read)
      r.(bytes_written).
  Definition with_steps steps (r : record) :=
    Build r.(allocations) steps r.(reads) r.(writes) r.(bytes_read)
      r.(bytes_written).
  Definition with_reads reads (r : record) :=
    Build r.(allocations) r.(steps) reads r.(writes) r.(bytes_read)
      r.(bytes_written).
  Definition with_writes writes (r : record) :=
    Build r.(allocations) r.(steps) r.(reads) writes r.(bytes_read)
      r.(bytes_written).
  Definition with_bytes_read bytes_read (r : record) :=
    Build r.(allocations) r.(steps) r.(reads) r.(writes) bytes_read
      r.(bytes_written).
  Definition with_bytes_written bytes_written (r : record) :=
    Build r.(allocations) r.(steps) r.(reads) r.(writes) r.(bytes_read)
      bytes_written.
End cost.
Definition cost := cost.record.

Definition encoding : Data_encoding.encoding t :=
  Data_encoding.union None
    [
      Data_encoding.__case_value "Limited" None (Data_encoding.Tag 0)
        Data_encoding.z
        (fun function_parameter =>
          match function_parameter with
          | Limited {| t.Limited.remaining := remaining |} => Some remaining
          | _ => None
          end)
        (fun remaining => Limited {| t.Limited.remaining := remaining |});
      Data_encoding.__case_value "Unaccounted" None (Data_encoding.Tag 1)
        (Data_encoding.constant "unaccounted")
        (fun function_parameter =>
          match function_parameter with
          | Unaccounted => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          let '_ := function_parameter in
          Unaccounted)
    ].

Definition pp (ppf : Format.formatter) (function_parameter : t) : unit :=
  match function_parameter with
  | Unaccounted =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "unaccounted"
          CamlinternalFormatBasics.End_of_format) "unaccounted")
  | Limited {| t.Limited.remaining := remaining |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String_literal " units remaining"
            CamlinternalFormatBasics.End_of_format)) "%s units remaining")
      (Z.to_string remaining)
  end.

Definition cost_encoding : Data_encoding.encoding cost :=
  Data_encoding.conv
    (fun function_parameter =>
      let '{|
        cost.allocations := allocations;
          cost.steps := steps;
          cost.reads := reads;
          cost.writes := writes;
          cost.bytes_read := bytes_read;
          cost.bytes_written := bytes_written
          |} := function_parameter in
      (allocations, steps, reads, writes, bytes_read, bytes_written))
    (fun function_parameter =>
      let '(allocations, steps, reads, writes, bytes_read, bytes_written) :=
        function_parameter in
      {| cost.allocations := allocations; cost.steps := steps;
        cost.reads := reads; cost.writes := writes;
        cost.bytes_read := bytes_read; cost.bytes_written := bytes_written |})
    None
    (Data_encoding.obj6
      (Data_encoding.req None None "allocations" Data_encoding.z)
      (Data_encoding.req None None "steps" Data_encoding.z)
      (Data_encoding.req None None "reads" Data_encoding.z)
      (Data_encoding.req None None "writes" Data_encoding.z)
      (Data_encoding.req None None "bytes_read" Data_encoding.z)
      (Data_encoding.req None None "bytes_written" Data_encoding.z)).

Definition pp_cost (ppf : Format.formatter) (function_parameter : cost)
  : unit :=
  let '{|
    cost.allocations := allocations;
      cost.steps := steps;
      cost.reads := reads;
      cost.writes := writes;
      cost.bytes_read := bytes_read;
      cost.bytes_written := bytes_written
      |} := function_parameter in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "(steps: "
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String_literal ", allocs: "
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal ", reads: "
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal " ("
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal
                        " bytes), writes: "
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.String_literal " ("
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.String_literal
                                " bytes))"
                                CamlinternalFormatBasics.End_of_format)))))))))))))
      "(steps: %s, allocs: %s, reads: %s (%s bytes), writes: %s (%s bytes))")
    (Z.to_string steps) (Z.to_string allocations) (Z.to_string reads)
    (Z.to_string bytes_read) (Z.to_string writes) (Z.to_string bytes_written).

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

Definition allocation_weight : Z.t := Z.of_int 2.

Definition step_weight : Z.t := Z.of_int 1.

Definition read_base_weight : Z.t := Z.of_int 100.

Definition write_base_weight : Z.t := Z.of_int 160.

Definition byte_read_weight : Z.t := Z.of_int 10.

Definition byte_written_weight : Z.t := Z.of_int 15.

Definition rescaling_bits : Z := 7.

Definition rescaling_mask : Z.t :=
  Z.sub (Z.shift_left Z.one rescaling_bits) Z.one.

Definition scale (z : Z.t) : Z.t := Z.shift_left z rescaling_bits.

Definition rescale (z : Z.t) : Z.t := Z.shift_right z rescaling_bits.

Definition cost_to_internal_gas (cost : cost) : internal_gas :=
  Z.add
    (Z.add (Z.mul (cost.allocations cost) allocation_weight)
      (Z.mul (cost.steps cost) step_weight))
    (Z.add
      (Z.add (Z.mul (cost.reads cost) read_base_weight)
        (Z.mul (cost.writes cost) write_base_weight))
      (Z.add (Z.mul (cost.bytes_read cost) byte_read_weight)
        (Z.mul (cost.bytes_written cost) byte_written_weight))).

Definition internal_gas_to_gas (__internal_gas_value : Z.t)
  : Z.t * internal_gas :=
  let gas := rescale __internal_gas_value in
  let rest := Z.logand __internal_gas_value rescaling_mask in
  (gas, rest).

Definition consume
  (block_gas : Z.t) (operation_gas : t) (__internal_gas_value : Z.t)
  (cost : cost) : Error_monad.tzresult (Z.t * t * Z.t) :=
  match operation_gas with
  | Unaccounted => Error_monad.ok (block_gas, Unaccounted, __internal_gas_value)
  | Limited {| t.Limited.remaining := remaining |} =>
    let cost_internal_gas := cost_to_internal_gas cost in
    let total_internal_gas := Z.add cost_internal_gas __internal_gas_value in
    let '(gas, rest) := internal_gas_to_gas total_internal_gas in
    if (|Compare.Z|).(Compare.S.op_gt) gas Z.zero then
      let remaining := Z.sub remaining gas in
      let block_remaining := Z.sub block_gas gas in
      if (|Compare.Z|).(Compare.S.op_lt) remaining Z.zero then
        Error_monad.__error_value extensible_type_value
      else
        if (|Compare.Z|).(Compare.S.op_lt) block_remaining Z.zero then
          Error_monad.__error_value extensible_type_value
        else
          Error_monad.ok
            (block_remaining, (Limited {| t.Limited.remaining := remaining |}),
              rest)
    else
      Error_monad.ok (block_gas, operation_gas, total_internal_gas)
  end.

Definition check_enough
  (block_gas : Z.t) (operation_gas : t) (__internal_gas_value : Z.t)
  (cost : cost) : Error_monad.tzresult unit :=
  Error_monad.op_gtpipequestion
    (consume block_gas operation_gas __internal_gas_value cost)
    (fun function_parameter =>
      let '(_block_remainig, _remaining, _internal_gas) := function_parameter in
      tt).

Definition internal_gas_zero : internal_gas := Z.zero.

Definition alloc_cost (n : Z) : cost :=
  {| cost.allocations := scale (Z.of_int (Pervasives.op_plus n 1));
    cost.steps := Z.zero; cost.reads := Z.zero; cost.writes := Z.zero;
    cost.bytes_read := Z.zero; cost.bytes_written := Z.zero |}.

Definition alloc_bytes_cost (n : Z) : cost :=
  alloc_cost (Pervasives.op_div (Pervasives.op_plus n 7) 8).

Definition alloc_bits_cost (n : Z) : cost :=
  alloc_cost (Pervasives.op_div (Pervasives.op_plus n 63) 64).

Definition atomic_step_cost (n : Z) : cost :=
  {| cost.allocations := Z.zero;
    cost.steps := Z.of_int (Pervasives.op_star 2 n); cost.reads := Z.zero;
    cost.writes := Z.zero; cost.bytes_read := Z.zero;
    cost.bytes_written := Z.zero |}.

Definition step_cost (n : Z) : cost :=
  {| cost.allocations := Z.zero; cost.steps := scale (Z.of_int n);
    cost.reads := Z.zero; cost.writes := Z.zero; cost.bytes_read := Z.zero;
    cost.bytes_written := Z.zero |}.

Definition free : cost :=
  {| cost.allocations := Z.zero; cost.steps := Z.zero; cost.reads := Z.zero;
    cost.writes := Z.zero; cost.bytes_read := Z.zero;
    cost.bytes_written := Z.zero |}.

Definition read_bytes_cost (n : Z.t) : cost :=
  {| cost.allocations := Z.zero; cost.steps := Z.zero;
    cost.reads := scale Z.one; cost.writes := Z.zero;
    cost.bytes_read := scale n; cost.bytes_written := Z.zero |}.

Definition write_bytes_cost (n : Z.t) : cost :=
  {| cost.allocations := Z.zero; cost.steps := Z.zero; cost.reads := Z.zero;
    cost.writes := Z.one; cost.bytes_read := Z.zero;
    cost.bytes_written := scale n |}.

Definition op_plusat (x : cost) (y : cost) : cost :=
  {| cost.allocations := Z.add (cost.allocations x) (cost.allocations y);
    cost.steps := Z.add (cost.steps x) (cost.steps y);
    cost.reads := Z.add (cost.reads x) (cost.reads y);
    cost.writes := Z.add (cost.writes x) (cost.writes y);
    cost.bytes_read := Z.add (cost.bytes_read x) (cost.bytes_read y);
    cost.bytes_written := Z.add (cost.bytes_written x) (cost.bytes_written y) |}.

Definition op_starat (x : Z) (y : cost) : cost :=
  {| cost.allocations := Z.mul (Z.of_int x) (cost.allocations y);
    cost.steps := Z.mul (Z.of_int x) (cost.steps y);
    cost.reads := Z.mul (Z.of_int x) (cost.reads y);
    cost.writes := Z.mul (Z.of_int x) (cost.writes y);
    cost.bytes_read := Z.mul (Z.of_int x) (cost.bytes_read y);
    cost.bytes_written := Z.mul (Z.of_int x) (cost.bytes_written y) |}.

Definition alloc_mbytes_cost (n : Z) : cost :=
  op_plusat (alloc_cost 12) (alloc_bytes_cost n).

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Gas_limit_repr_mli

  • OCaml size: 71 lines
  • Coq size: 83 lines (+16% compared to OCaml)
gas_limit_repr.mli 2 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Unaccounted | Limited of {remaining : Z.t}

type internal_gas

val encoding : t Data_encoding.encoding

val pp : Format.formatter -> t -> unit

type cost

val cost_encoding : cost Data_encoding.encoding

val pp_cost : Format.formatter -> cost -> unit

type error += Block_quota_exceeded (* `Temporary *)

type error += Operation_quota_exceeded (* `Temporary *)

val consume :
  Z.t -> t -> internal_gas -> cost -> (Z.t * t * internal_gas) tzresult

val check_enough : Z.t -> t -> internal_gas -> cost -> unit tzresult

val internal_gas_zero : internal_gas

val free : cost

val atomic_step_cost : int -> cost

val step_cost : int -> cost

val alloc_cost : int -> cost

val alloc_bytes_cost : int -> cost

val alloc_mbytes_cost : int -> cost

val alloc_bits_cost : int -> cost

val read_bytes_cost : Z.t -> cost

val write_bytes_cost : Z.t -> cost

val ( *@ ) : int -> cost -> cost

val ( +@ ) : cost -> cost -> cost
Gas_limit_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Module t.
  Module Limited.
    Record record {remaining : Set} := {
      remaining : remaining }.
    Arguments record : clear implicits.
  End Limited.
  Definition Limited_skeleton := Limited.record.
End t.

Reserved Notation "'t.Limited".

Inductive t : Set :=
| Unaccounted : t
| Limited : 't.Limited -> t

where "'t.Limited" := (t.Limited_skeleton Z.t).

Module ConstructorRecordNotations_t.
  Module t.
    Definition Limited := 't.Limited.
  End t.
End ConstructorRecordNotations_t.
Import ConstructorRecordNotations_t.

Parameter internal_gas : Set.

Parameter encoding : Data_encoding.encoding t.

Parameter pp : Format.formatter -> t -> unit.

Parameter cost : Set.

Parameter cost_encoding : Data_encoding.encoding cost.

Parameter pp_cost : Format.formatter -> cost -> unit.

(* extensible_type error *)

(* extensible_type error *)

Parameter consume :
  Z.t -> t -> internal_gas -> cost ->
  Error_monad.tzresult (Z.t * t * internal_gas).

Parameter check_enough :
  Z.t -> t -> internal_gas -> cost -> Error_monad.tzresult unit.

Parameter internal_gas_zero : internal_gas.

Parameter free : cost.

Parameter atomic_step_cost : Z -> cost.

Parameter step_cost : Z -> cost.

Parameter alloc_cost : Z -> cost.

Parameter alloc_bytes_cost : Z -> cost.

Parameter alloc_mbytes_cost : Z -> cost.

Parameter alloc_bits_cost : Z -> cost.

Parameter read_bytes_cost : Z.t -> cost.

Parameter write_bytes_cost : Z.t -> cost.

Parameter op_starat : Z -> cost -> cost.

Parameter op_plusat : cost -> cost -> cost.

Helpers_services

  • OCaml size: 890 lines
  • Coq size: 1420 lines (+59% compared to OCaml)
helpers_services.ml 357 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

type error += Cannot_parse_operation (* `Branch *)

let () =
  register_error_kind
    `Branch
    ~id:"operation.cannot_parse"
    ~title:"Cannot parse operation"
    ~description:"The operation is ill-formed or for another protocol version"
    ~pp:(fun ppf () -> Format.fprintf ppf "The operation cannot be parsed")
    Data_encoding.unit
    (function Cannot_parse_operation -> Some () | _ -> None)
    (fun () -> Cannot_parse_operation)

let parse_operation (op : Operation.raw) =
  match
    Data_encoding.Binary.of_bytes Operation.protocol_data_encoding op.proto
  with
  | Some protocol_data ->
      ok {shell = op.shell; protocol_data}
  | None ->
      error Cannot_parse_operation

let path = RPC_path.(open_root / "helpers")

module Scripts = struct
  module S = struct
    open Data_encoding

    let path = RPC_path.(path / "scripts")

    let run_code_input_encoding =
      obj9
        (req "script" Script.expr_encoding)
        (req "storage" Script.expr_encoding)
        (req "input" Script.expr_encoding)
        (req "amount" Tez.encoding)
        (req "chain_id" Chain_id.encoding)
        (opt "source" Contract.encoding)
        (opt "payer" Contract.encoding)
        (opt "gas" z)
        (dft "entrypoint" string "default")

    let trace_encoding =
      def "scripted.trace" @@ list
      @@ obj3
           (req "location" Script.location_encoding)
           (req "gas" Gas.encoding)
           (req
              "stack"
              (list
                 (obj2 (req "item" Script.expr_encoding) (opt "annot" string))))

    let run_code =
      RPC_service.post_service
        ~description:"Run a piece of code in the current context"
        ~query:RPC_query.empty
        ~input:run_code_input_encoding
        ~output:
          (obj3
             (req "storage" Script.expr_encoding)
             (req "operations" (list Operation.internal_operation_encoding))
             (opt "big_map_diff" Contract.big_map_diff_encoding))
        RPC_path.(path / "run_code")

    let trace_code =
      RPC_service.post_service
        ~description:
          "Run a piece of code in the current context, keeping a trace"
        ~query:RPC_query.empty
        ~input:run_code_input_encoding
        ~output:
          (obj4
             (req "storage" Script.expr_encoding)
             (req "operations" (list Operation.internal_operation_encoding))
             (req "trace" trace_encoding)
             (opt "big_map_diff" Contract.big_map_diff_encoding))
        RPC_path.(path / "trace_code")

    let typecheck_code =
      RPC_service.post_service
        ~description:"Typecheck a piece of code in the current context"
        ~query:RPC_query.empty
        ~input:(obj2 (req "program" Script.expr_encoding) (opt "gas" z))
        ~output:
          (obj2
             (req "type_map" Script_tc_errors_registration.type_map_enc)
             (req "gas" Gas.encoding))
        RPC_path.(path / "typecheck_code")

    let typecheck_data =
      RPC_service.post_service
        ~description:
          "Check that some data expression is well formed and of a given type \
           in the current context"
        ~query:RPC_query.empty
        ~input:
          (obj3
             (req "data" Script.expr_encoding)
             (req "type" Script.expr_encoding)
             (opt "gas" z))
        ~output:(obj1 (req "gas" Gas.encoding))
        RPC_path.(path / "typecheck_data")

    let pack_data =
      RPC_service.post_service
        ~description:
          "Computes the serialized version of some data expression using the \
           same algorithm as script instruction PACK"
        ~input:
          (obj3
             (req "data" Script.expr_encoding)
             (req "type" Script.expr_encoding)
             (opt "gas" z))
        ~output:(obj2 (req "packed" bytes) (req "gas" Gas.encoding))
        ~query:RPC_query.empty
        RPC_path.(path / "pack_data")

    let run_operation =
      RPC_service.post_service
        ~description:"Run an operation without signature checks"
        ~query:RPC_query.empty
        ~input:
          (obj2
             (req "operation" Operation.encoding)
             (req "chain_id" Chain_id.encoding))
        ~output:Apply_results.operation_data_and_metadata_encoding
        RPC_path.(path / "run_operation")

    let entrypoint_type =
      RPC_service.post_service
        ~description:"Return the type of the given entrypoint"
        ~query:RPC_query.empty
        ~input:
          (obj2
             (req "script" Script.expr_encoding)
             (dft "entrypoint" string "default"))
        ~output:(obj1 (req "entrypoint_type" Script.expr_encoding))
        RPC_path.(path / "entrypoint")

    let list_entrypoints =
      RPC_service.post_service
        ~description:"Return the list of entrypoints of the given script"
        ~query:RPC_query.empty
        ~input:(obj1 (req "script" Script.expr_encoding))
        ~output:
          (obj2
             (dft
                "unreachable"
                (Data_encoding.list
                   (obj1
                      (req
                         "path"
                         (Data_encoding.list
                            Michelson_v1_primitives.prim_encoding))))
                [])
             (req "entrypoints" (assoc Script.expr_encoding)))
        RPC_path.(path / "entrypoints")
  end

  let register () =
    let open Services_registration in
    let originate_dummy_contract ctxt script =
      let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in
      Contract.fresh_contract_from_current_nonce ctxt
      >>=? fun (ctxt, dummy_contract) ->
      let balance =
        match Tez.of_mutez 4_000_000_000_000L with
        | Some balance ->
            balance
        | None ->
            assert false
      in
      Contract.originate
        ctxt
        dummy_contract
        ~balance
        ~delegate:None
        ~script:(script, None)
      >>=? fun ctxt -> return (ctxt, dummy_contract)
    in
    register0
      S.run_code
      (fun ctxt
           ()
           ( code,
             storage,
             parameter,
             amount,
             chain_id,
             source,
             payer,
             gas,
             entrypoint )
           ->
        let storage = Script.lazy_expr storage in
        let code = Script.lazy_expr code in
        originate_dummy_contract ctxt {storage; code}
        >>=? fun (ctxt, dummy_contract) ->
        let (source, payer) =
          match (source, payer) with
          | (Some source, Some payer) ->
              (source, payer)
          | (Some source, None) ->
              (source, source)
          | (None, Some payer) ->
              (payer, payer)
          | (None, None) ->
              (dummy_contract, dummy_contract)
        in
        let gas =
          match gas with
          | Some gas ->
              gas
          | None ->
              Constants.hard_gas_limit_per_operation ctxt
        in
        let ctxt = Gas.set_limit ctxt gas in
        let step_constants =
          let open Script_interpreter in
          {source; payer; self = dummy_contract; amount; chain_id}
        in
        Script_interpreter.execute
          ctxt
          Readable
          step_constants
          ~script:{storage; code}
          ~entrypoint
          ~parameter
        >>=? fun {Script_interpreter.storage; operations; big_map_diff; _} ->
        return (storage, operations, big_map_diff)) ;
    register0
      S.trace_code
      (fun ctxt
           ()
           ( code,
             storage,
             parameter,
             amount,
             chain_id,
             source,
             payer,
             gas,
             entrypoint )
           ->
        let storage = Script.lazy_expr storage in
        let code = Script.lazy_expr code in
        originate_dummy_contract ctxt {storage; code}
        >>=? fun (ctxt, dummy_contract) ->
        let (source, payer) =
          match (source, payer) with
          | (Some source, Some payer) ->
              (source, payer)
          | (Some source, None) ->
              (source, source)
          | (None, Some payer) ->
              (payer, payer)
          | (None, None) ->
              (dummy_contract, dummy_contract)
        in
        let gas =
          match gas with
          | Some gas ->
              gas
          | None ->
              Constants.hard_gas_limit_per_operation ctxt
        in
        let ctxt = Gas.set_limit ctxt gas in
        let step_constants =
          let open Script_interpreter in
          {source; payer; self = dummy_contract; amount; chain_id}
        in
        Script_interpreter.trace
          ctxt
          Readable
          step_constants
          ~script:{storage; code}
          ~entrypoint
          ~parameter
        >>=? fun ( {Script_interpreter.storage; operations; big_map_diff; _},
                   trace ) ->
        return (storage, operations, trace, big_map_diff)) ;
    register0 S.typecheck_code (fun ctxt () (expr, maybe_gas) ->
        let ctxt =
          match maybe_gas with
          | None ->
              Gas.set_unlimited ctxt
          | Some gas ->
              Gas.set_limit ctxt gas
        in
        Script_ir_translator.typecheck_code ctxt expr
        >>=? fun (res, ctxt) -> return (res, Gas.level ctxt)) ;
    register0 S.typecheck_data (fun ctxt () (data, ty, maybe_gas) ->
        let ctxt =
          match maybe_gas with
          | None ->
              Gas.set_unlimited ctxt
          | Some gas ->
              Gas.set_limit ctxt gas
        in
        Script_ir_translator.typecheck_data ctxt (data, ty)
        >>=? fun ctxt -> return (Gas.level ctxt)) ;
    register0 S.pack_data (fun ctxt () (expr, typ, maybe_gas) ->
        let open Script_ir_translator in
        let ctxt =
          match maybe_gas with
          | None ->
              Gas.set_unlimited ctxt
          | Some gas ->
              Gas.set_limit ctxt gas
        in
        Lwt.return (parse_packable_ty ctxt ~legacy:true (Micheline.root typ))
        >>=? fun (Ex_ty typ, ctxt) ->
        parse_data ctxt ~legacy:true typ (Micheline.root expr)
        >>=? fun (data, ctxt) ->
        Script_ir_translator.pack_data ctxt typ data
        >>=? fun (bytes, ctxt) -> return (bytes, Gas.level ctxt)) ;
    register0
      S.run_operation
      (fun ctxt
           ()
           ({shell; protocol_data = Operation_data protocol_data}, chain_id)
           ->
        (* this code is a duplicate of Apply without signature check *)
        let partial_precheck_manager_contents (type kind) ctxt
            (op : kind Kind.manager contents) : context tzresult Lwt.t =
          let (Manager_operation
                {source; fee; counter; operation; gas_limit; storage_limit}) =
            op
          in
          Lwt.return (Gas.check_limit ctxt gas_limit)
          >>=? fun () ->
          let ctxt = Gas.set_limit ctxt gas_limit in
          Lwt.return (Fees.check_storage_limit ctxt storage_limit)
          >>=? fun () ->
          Contract.must_be_allocated ctxt (Contract.implicit_contract source)
          >>=? fun () ->
          Contract.check_counter_increment ctxt source counter
          >>=? fun () ->
          ( match operation with
          | Reveal pk ->
              Contract.reveal_manager_key ctxt source pk
          | Transaction {parameters; _} ->
              (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *)
              let arg_bytes =
                Data_encoding.Binary.to_bytes_exn
                  Script.lazy_expr_encoding
                  parameters
              in
              let arg =
                match
                  Data_encoding.Binary.of_bytes
                    Script.lazy_expr_encoding
                    arg_bytes
                with
                | Some arg ->
                    arg
                | None ->
                    assert false
              in
              (* Fail quickly if not enough gas for minimal deserialization cost *)
              Lwt.return
              @@ record_trace Apply.Gas_quota_exceeded_init_deserialize
              @@ Gas.check_enough ctxt (Script.minimal_deserialize_cost arg)
              >>=? fun () ->
              (* Fail if not enough gas for complete deserialization cost *)
              trace Apply.Gas_quota_exceeded_init_deserialize
              @@ Script.force_decode ctxt arg
              >>|? fun (_arg, ctxt) -> ctxt
          | Origination {script; _} ->
              (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *)
              let script_bytes =
                Data_encoding.Binary.to_bytes_exn Script.encoding script
              in
              let script =
                match
                  Data_encoding.Binary.of_bytes Script.encoding script_bytes
                with
                | Some script ->
                    script
                | None ->
                    assert false
              in
              (* Fail quickly if not enough gas for minimal deserialization cost *)
              Lwt.return
              @@ record_trace Apply.Gas_quota_exceeded_init_deserialize
              @@ ( Gas.consume
                     ctxt
                     (Script.minimal_deserialize_cost script.code)
                 >>? fun ctxt ->
                 Gas.check_enough
                   ctxt
                   (Script.minimal_deserialize_cost script.storage) )
              >>=? fun () ->
              (* Fail if not enough gas for complete deserialization cost *)
              trace Apply.Gas_quota_exceeded_init_deserialize
              @@ Script.force_decode ctxt script.code
              >>=? fun (_code, ctxt) ->
              trace Apply.Gas_quota_exceeded_init_deserialize
              @@ Script.force_decode ctxt script.storage
              >>|? fun (_storage, ctxt) -> ctxt
          | _ ->
              return ctxt )
          >>=? fun ctxt ->
          Contract.get_manager_key ctxt source
          >>=? fun _public_key ->
          (* signature check unplugged from here *)
          Contract.increment_counter ctxt source
          >>=? fun ctxt ->
          Contract.spend ctxt (Contract.implicit_contract source) fee
          >>=? fun ctxt -> return ctxt
        in
        let rec partial_precheck_manager_contents_list :
            type kind.
            Alpha_context.t ->
            kind Kind.manager contents_list ->
            context tzresult Lwt.t =
         fun ctxt contents_list ->
          match contents_list with
          | Single (Manager_operation _ as op) ->
              partial_precheck_manager_contents ctxt op
          | Cons ((Manager_operation _ as op), rest) ->
              partial_precheck_manager_contents ctxt op
              >>=? fun ctxt -> partial_precheck_manager_contents_list ctxt rest
        in
        let return contents =
          return
            ( Operation_data protocol_data,
              Apply_results.Operation_metadata {contents} )
        in
        let operation : _ operation = {shell; protocol_data} in
        let hash = Operation.hash {shell; protocol_data} in
        let ctxt = Contract.init_origination_nonce ctxt hash in
        let baker = Signature.Public_key_hash.zero in
        match protocol_data.contents with
        | Single (Manager_operation _) as op ->
            partial_precheck_manager_contents_list ctxt op
            >>=? fun ctxt ->
            Apply.apply_manager_contents_list ctxt Optimized baker chain_id op
            >>= fun (_ctxt, result) -> return result
        | Cons (Manager_operation _, _) as op ->
            partial_precheck_manager_contents_list ctxt op
            >>=? fun ctxt ->
            Apply.apply_manager_contents_list ctxt Optimized baker chain_id op
            >>= fun (_ctxt, result) -> return result
        | _ ->
            Apply.apply_contents_list
              ctxt
              chain_id
              Optimized
              shell.branch
              baker
              operation
              operation.protocol_data.contents
            >>=? fun (_ctxt, result) -> return result) ;
    register0 S.entrypoint_type (fun ctxt () (expr, entrypoint) ->
        let ctxt = Gas.set_unlimited ctxt in
        let legacy = false in
        let open Script_ir_translator in
        Lwt.return
          ( parse_toplevel ~legacy expr
          >>? fun (arg_type, _, _, root_name) ->
          parse_ty
            ctxt
            ~legacy
            ~allow_big_map:true
            ~allow_operation:false
            ~allow_contract:true
            arg_type
          >>? fun (Ex_ty arg_type, _) ->
          Script_ir_translator.find_entrypoint ~root_name arg_type entrypoint
          )
        >>=? fun (_f, Ex_ty ty) ->
        unparse_ty ctxt ty
        >>=? fun (ty_node, _) -> return (Micheline.strip_locations ty_node)) ;
    register0 S.list_entrypoints (fun ctxt () expr ->
        let ctxt = Gas.set_unlimited ctxt in
        let legacy = false in
        let open Script_ir_translator in
        Lwt.return
          ( parse_toplevel ~legacy expr
          >>? fun (arg_type, _, _, root_name) ->
          parse_ty
            ctxt
            ~legacy
            ~allow_big_map:true
            ~allow_operation:false
            ~allow_contract:true
            arg_type
          >>? fun (Ex_ty arg_type, _) ->
          Script_ir_translator.list_entrypoints ~root_name arg_type ctxt )
        >>=? fun (unreachable_entrypoint, map) ->
        return
          ( unreachable_entrypoint,
            Entrypoints_map.fold
              (fun entry (_, ty) acc ->
                (entry, Micheline.strip_locations ty) :: acc)
              map
              [] ))

  let run_code ctxt block code
      (storage, input, amount, chain_id, source, payer, gas, entrypoint) =
    RPC_context.make_call0
      S.run_code
      ctxt
      block
      ()
      (code, storage, input, amount, chain_id, source, payer, gas, entrypoint)

  let trace_code ctxt block code
      (storage, input, amount, chain_id, source, payer, gas, entrypoint) =
    RPC_context.make_call0
      S.trace_code
      ctxt
      block
      ()
      (code, storage, input, amount, chain_id, source, payer, gas, entrypoint)

  let typecheck_code ctxt block =
    RPC_context.make_call0 S.typecheck_code ctxt block ()

  let typecheck_data ctxt block =
    RPC_context.make_call0 S.typecheck_data ctxt block ()

  let pack_data ctxt block = RPC_context.make_call0 S.pack_data ctxt block ()

  let run_operation ctxt block =
    RPC_context.make_call0 S.run_operation ctxt block ()

  let entrypoint_type ctxt block =
    RPC_context.make_call0 S.entrypoint_type ctxt block ()

  let list_entrypoints ctxt block =
    RPC_context.make_call0 S.list_entrypoints ctxt block ()
end

module Forge = struct
  module S = struct
    open Data_encoding

    let path = RPC_path.(path / "forge")

    let operations =
      RPC_service.post_service
        ~description:"Forge an operation"
        ~query:RPC_query.empty
        ~input:Operation.unsigned_encoding
        ~output:bytes
        RPC_path.(path / "operations")

    let empty_proof_of_work_nonce =
      MBytes.of_string
        (String.make Constants_repr.proof_of_work_nonce_size '\000')

    let protocol_data =
      RPC_service.post_service
        ~description:"Forge the protocol-specific part of a block header"
        ~query:RPC_query.empty
        ~input:
          (obj3
             (req "priority" uint16)
             (opt "nonce_hash" Nonce_hash.encoding)
             (dft
                "proof_of_work_nonce"
                (Fixed.bytes Alpha_context.Constants.proof_of_work_nonce_size)
                empty_proof_of_work_nonce))
        ~output:(obj1 (req "protocol_data" bytes))
        RPC_path.(path / "protocol_data")
  end

  let register () =
    let open Services_registration in
    register0_noctxt S.operations (fun () (shell, proto) ->
        return
          (Data_encoding.Binary.to_bytes_exn
             Operation.unsigned_encoding
             (shell, proto))) ;
    register0_noctxt
      S.protocol_data
      (fun () (priority, seed_nonce_hash, proof_of_work_nonce) ->
        return
          (Data_encoding.Binary.to_bytes_exn
             Block_header.contents_encoding
             {priority; seed_nonce_hash; proof_of_work_nonce}))

  module Manager = struct
    let operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee
        ~gas_limit ~storage_limit operations =
      Contract_services.manager_key ctxt block source
      >>= function
      | Error _ as e ->
          Lwt.return e
      | Ok revealed ->
          let ops =
            List.map
              (fun (Manager operation) ->
                Contents
                  (Manager_operation
                     {
                       source;
                       counter;
                       operation;
                       fee;
                       gas_limit;
                       storage_limit;
                     }))
              operations
          in
          let ops =
            match (sourcePubKey, revealed) with
            | (None, _) | (_, Some _) ->
                ops
            | (Some pk, None) ->
                let operation = Reveal pk in
                Contents
                  (Manager_operation
                     {
                       source;
                       counter;
                       operation;
                       fee;
                       gas_limit;
                       storage_limit;
                     })
                :: ops
          in
          RPC_context.make_call0
            S.operations
            ctxt
            block
            ()
            ({branch}, Operation.of_list ops)

    let reveal ctxt block ~branch ~source ~sourcePubKey ~counter ~fee () =
      operations
        ctxt
        block
        ~branch
        ~source
        ~sourcePubKey
        ~counter
        ~fee
        ~gas_limit:Z.zero
        ~storage_limit:Z.zero
        []

    let transaction ctxt block ~branch ~source ?sourcePubKey ~counter ~amount
        ~destination ?(entrypoint = "default") ?parameters ~gas_limit
        ~storage_limit ~fee () =
      let parameters =
        Option.unopt_map
          ~f:Script.lazy_expr
          ~default:Script.unit_parameter
          parameters
      in
      operations
        ctxt
        block
        ~branch
        ~source
        ?sourcePubKey
        ~counter
        ~fee
        ~gas_limit
        ~storage_limit
        [Manager (Transaction {amount; parameters; destination; entrypoint})]

    let origination ctxt block ~branch ~source ?sourcePubKey ~counter ~balance
        ?delegatePubKey ~script ~gas_limit ~storage_limit ~fee () =
      operations
        ctxt
        block
        ~branch
        ~source
        ?sourcePubKey
        ~counter
        ~fee
        ~gas_limit
        ~storage_limit
        [ Manager
            (Origination
               {
                 delegate = delegatePubKey;
                 script;
                 credit = balance;
                 preorigination = None;
               }) ]

    let delegation ctxt block ~branch ~source ?sourcePubKey ~counter ~fee
        delegate =
      operations
        ctxt
        block
        ~branch
        ~source
        ?sourcePubKey
        ~counter
        ~fee
        ~gas_limit:Z.zero
        ~storage_limit:Z.zero
        [Manager (Delegation delegate)]
  end

  let operation ctxt block ~branch operation =
    RPC_context.make_call0
      S.operations
      ctxt
      block
      ()
      ({branch}, Contents_list (Single operation))

  let endorsement ctxt b ~branch ~level () =
    operation ctxt b ~branch (Endorsement {level})

  let proposals ctxt b ~branch ~source ~period ~proposals () =
    operation ctxt b ~branch (Proposals {source; period; proposals})

  let ballot ctxt b ~branch ~source ~period ~proposal ~ballot () =
    operation ctxt b ~branch (Ballot {source; period; proposal; ballot})

  let seed_nonce_revelation ctxt block ~branch ~level ~nonce () =
    operation ctxt block ~branch (Seed_nonce_revelation {level; nonce})

  let double_baking_evidence ctxt block ~branch ~bh1 ~bh2 () =
    operation ctxt block ~branch (Double_baking_evidence {bh1; bh2})

  let double_endorsement_evidence ctxt block ~branch ~op1 ~op2 () =
    operation ctxt block ~branch (Double_endorsement_evidence {op1; op2})

  let empty_proof_of_work_nonce =
    MBytes.of_string
      (String.make Constants_repr.proof_of_work_nonce_size '\000')

  let protocol_data ctxt block ~priority ?seed_nonce_hash
      ?(proof_of_work_nonce = empty_proof_of_work_nonce) () =
    RPC_context.make_call0
      S.protocol_data
      ctxt
      block
      ()
      (priority, seed_nonce_hash, proof_of_work_nonce)
end

module Parse = struct
  module S = struct
    open Data_encoding

    let path = RPC_path.(path / "parse")

    let operations =
      RPC_service.post_service
        ~description:"Parse operations"
        ~query:RPC_query.empty
        ~input:
          (obj2
             (req "operations" (list (dynamic_size Operation.raw_encoding)))
             (opt "check_signature" bool))
        ~output:(list (dynamic_size Operation.encoding))
        RPC_path.(path / "operations")

    let block =
      RPC_service.post_service
        ~description:"Parse a block"
        ~query:RPC_query.empty
        ~input:Block_header.raw_encoding
        ~output:Block_header.protocol_data_encoding
        RPC_path.(path / "block")
  end

  let parse_protocol_data protocol_data =
    match
      Data_encoding.Binary.of_bytes
        Block_header.protocol_data_encoding
        protocol_data
    with
    | None ->
        failwith "Cant_parse_protocol_data"
    | Some protocol_data ->
        return protocol_data

  let register () =
    let open Services_registration in
    register0 S.operations (fun _ctxt () (operations, check) ->
        map_s
          (fun raw ->
            Lwt.return (parse_operation raw)
            >>=? fun op ->
            ( match check with
            | Some true ->
                return_unit (* FIXME *)
            (* I.check_signature ctxt *)
            (* op.protocol_data.signature op.shell op.protocol_data.contents *)
            | Some false | None ->
                return_unit )
            >>|? fun () -> op)
          operations) ;
    register0_noctxt S.block (fun () raw_block ->
        parse_protocol_data raw_block.protocol_data)

  let operations ctxt block ?check operations =
    RPC_context.make_call0 S.operations ctxt block () (operations, check)

  let block ctxt block shell protocol_data =
    RPC_context.make_call0
      S.block
      ctxt
      block
      ()
      ({shell; protocol_data} : Block_header.raw)
end

module S = struct
  open Data_encoding

  type level_query = {offset : int32}

  let level_query : level_query RPC_query.t =
    let open RPC_query in
    query (fun offset -> {offset})
    |+ field "offset" RPC_arg.int32 0l (fun t -> t.offset)
    |> seal

  let current_level =
    RPC_service.get_service
      ~description:
        "Returns the level of the interrogated block, or the one of a block \
         located `offset` blocks after in the chain (or before when \
         negative). For instance, the next block if `offset` is 1."
      ~query:level_query
      ~output:Level.encoding
      RPC_path.(path / "current_level")

  let levels_in_current_cycle =
    RPC_service.get_service
      ~description:"Levels of a cycle"
      ~query:level_query
      ~output:
        (obj2 (req "first" Raw_level.encoding) (req "last" Raw_level.encoding))
      RPC_path.(path / "levels_in_current_cycle")
end

let register () =
  Scripts.register () ;
  Forge.register () ;
  Parse.register () ;
  let open Services_registration in
  register0 S.current_level (fun ctxt q () ->
      let level = Level.current ctxt in
      return (Level.from_raw ctxt ~offset:q.offset level.level)) ;
  register0 S.levels_in_current_cycle (fun ctxt q () ->
      let levels = Level.levels_in_current_cycle ctxt ~offset:q.offset () in
      match levels with
      | [] ->
          raise Not_found
      | _ ->
          let first = List.hd (List.rev levels) in
          let last = List.hd levels in
          return (first.level, last.level))

let current_level ctxt ?(offset = 0l) block =
  RPC_context.make_call0 S.current_level ctxt block {offset} ()

let levels_in_current_cycle ctxt ?(offset = 0l) block =
  RPC_context.make_call0 S.levels_in_current_cycle ctxt block {offset} ()
Helpers_services.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Apply_results.
Require Tezos.Constants_repr.
Require Tezos.Contract_services.
Require Tezos.Michelson_v1_primitives.
Require Tezos.Nonce_hash.
Require Tezos.Script_ir_translator.
Require Tezos.Script_tc_errors_registration.
Require Tezos.Services_registration.

Import Alpha_context.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition parse_operation (op : Alpha_context.Operation.raw)
  : Error_monad.tzresult Alpha_context.packed_operation :=
  match
    Data_encoding.Binary.of_bytes Alpha_context.Operation.protocol_data_encoding
      (Alpha_context.Operation.raw.proto op) with
  | Some protocol_data =>
    Error_monad.ok
      {|
        Alpha_context.packed_operation.shell :=
          Alpha_context.Operation.raw.shell op;
        Alpha_context.packed_operation.protocol_data := protocol_data |}
  | None => Error_monad.__error_value extensible_type_value
  end.

Definition path : RPC_path.path Updater.rpc_context Updater.rpc_context :=
  RPC_path.op_div RPC_path.open_root "helpers".

Module Scripts.
  Module S.
    Import Data_encoding.
    
    Definition path : RPC_path.path Updater.rpc_context Updater.rpc_context :=
      RPC_path.op_div path "scripts".
    
    Definition run_code_input_encoding
      : Data_encoding.encoding
        (Alpha_context.Script.expr * Alpha_context.Script.expr *
          Alpha_context.Script.expr * Alpha_context.Tez.t *
          (|Chain_id|).(S.HASH.t) * option Alpha_context.Contract.t *
          option Alpha_context.Contract.t * option Z.t * string) :=
      Data_encoding.obj9
        (Data_encoding.req None None "script" Alpha_context.Script.expr_encoding)
        (Data_encoding.req None None "storage"
          Alpha_context.Script.expr_encoding)
        (Data_encoding.req None None "input" Alpha_context.Script.expr_encoding)
        (Data_encoding.req None None "amount" Alpha_context.Tez.encoding)
        (Data_encoding.req None None "chain_id" (|Chain_id|).(S.HASH.encoding))
        (Data_encoding.opt None None "source" Alpha_context.Contract.encoding)
        (Data_encoding.opt None None "payer" Alpha_context.Contract.encoding)
        (Data_encoding.opt None None "gas" Data_encoding.z)
        (Data_encoding.dft None None "entrypoint" Data_encoding.__string_value
          "default").
    
    Definition trace_encoding
      : Data_encoding.encoding
        (list
          (Alpha_context.Script.location * Alpha_context.Gas.t *
            list (Alpha_context.Script.expr * option string))) :=
      Pervasives.op_atat
        (let arg := Data_encoding.def "scripted.trace" in
        fun eta => arg None None eta)
        (Pervasives.op_atat
          (let arg := Data_encoding.__list_value in
          fun eta => arg None eta)
          (Data_encoding.obj3
            (Data_encoding.req None None "location"
              Alpha_context.Script.location_encoding)
            (Data_encoding.req None None "gas" Alpha_context.Gas.encoding)
            (Data_encoding.req None None "stack"
              (Data_encoding.__list_value None
                (Data_encoding.obj2
                  (Data_encoding.req None None "item"
                    Alpha_context.Script.expr_encoding)
                  (Data_encoding.opt None None "annot"
                    Data_encoding.__string_value)))))).
    
    Definition run_code
      : RPC_service.service (* `POST *) unit Updater.rpc_context
        Updater.rpc_context unit
        (Alpha_context.Script.expr * Alpha_context.Script.expr *
          Alpha_context.Script.expr * Alpha_context.Tez.t *
          (|Chain_id|).(S.HASH.t) * option Alpha_context.Contract.t *
          option Alpha_context.Contract.t * option Z.t * string)
        (Alpha_context.Script.expr *
          list Alpha_context.packed_internal_operation *
          option Alpha_context.Contract.big_map_diff) :=
      RPC_service.post_service
        (Some "Run a piece of code in the current context") RPC_query.empty
        run_code_input_encoding
        (Data_encoding.obj3
          (Data_encoding.req None None "storage"
            Alpha_context.Script.expr_encoding)
          (Data_encoding.req None None "operations"
            (Data_encoding.__list_value None
              Alpha_context.Operation.internal_operation_encoding))
          (Data_encoding.opt None None "big_map_diff"
            Alpha_context.Contract.big_map_diff_encoding))
        (RPC_path.op_div path "run_code").
    
    Definition trace_code
      : RPC_service.service (* `POST *) unit Updater.rpc_context
        Updater.rpc_context unit
        (Alpha_context.Script.expr * Alpha_context.Script.expr *
          Alpha_context.Script.expr * Alpha_context.Tez.t *
          (|Chain_id|).(S.HASH.t) * option Alpha_context.Contract.t *
          option Alpha_context.Contract.t * option Z.t * string)
        (Alpha_context.Script.expr *
          list Alpha_context.packed_internal_operation *
          list
            (Alpha_context.Script.location * Alpha_context.Gas.t *
              list (Alpha_context.Script.expr * option string)) *
          option Alpha_context.Contract.big_map_diff) :=
      RPC_service.post_service
        (Some "Run a piece of code in the current context, keeping a trace")
        RPC_query.empty run_code_input_encoding
        (Data_encoding.obj4
          (Data_encoding.req None None "storage"
            Alpha_context.Script.expr_encoding)
          (Data_encoding.req None None "operations"
            (Data_encoding.__list_value None
              Alpha_context.Operation.internal_operation_encoding))
          (Data_encoding.req None None "trace" trace_encoding)
          (Data_encoding.opt None None "big_map_diff"
            Alpha_context.Contract.big_map_diff_encoding))
        (RPC_path.op_div path "trace_code").
    
    Definition typecheck_code
      : RPC_service.service (* `POST *) unit Updater.rpc_context
        Updater.rpc_context unit (Alpha_context.Script.expr * option Z.t)
        (list
          (Alpha_context.Script.location *
            (list (Alpha_context.Script.expr * list string) *
              list (Alpha_context.Script.expr * list string))) *
          Alpha_context.Gas.t) :=
      RPC_service.post_service
        (Some "Typecheck a piece of code in the current context")
        RPC_query.empty
        (Data_encoding.obj2
          (Data_encoding.req None None "program"
            Alpha_context.Script.expr_encoding)
          (Data_encoding.opt None None "gas" Data_encoding.z))
        (Data_encoding.obj2
          (Data_encoding.req None None "type_map"
            Script_tc_errors_registration.type_map_enc)
          (Data_encoding.req None None "gas" Alpha_context.Gas.encoding))
        (RPC_path.op_div path "typecheck_code").
    
    Definition typecheck_data
      : RPC_service.service (* `POST *) unit Updater.rpc_context
        Updater.rpc_context unit
        (Alpha_context.Script.expr * Alpha_context.Script.expr * option Z.t)
        Alpha_context.Gas.t :=
      RPC_service.post_service
        (Some
          "Check that some data expression is well formed and of a given type in the current context")
        RPC_query.empty
        (Data_encoding.obj3
          (Data_encoding.req None None "data" Alpha_context.Script.expr_encoding)
          (Data_encoding.req None None "type" Alpha_context.Script.expr_encoding)
          (Data_encoding.opt None None "gas" Data_encoding.z))
        (Data_encoding.obj1
          (Data_encoding.req None None "gas" Alpha_context.Gas.encoding))
        (RPC_path.op_div path "typecheck_data").
    
    Definition pack_data
      : RPC_service.service (* `POST *) unit Updater.rpc_context
        Updater.rpc_context unit
        (Alpha_context.Script.expr * Alpha_context.Script.expr * option Z.t)
        (MBytes.t * Alpha_context.Gas.t) :=
      RPC_service.post_service
        (Some
          "Computes the serialized version of some data expression using the same algorithm as script instruction PACK")
        RPC_query.empty
        (Data_encoding.obj3
          (Data_encoding.req None None "data" Alpha_context.Script.expr_encoding)
          (Data_encoding.req None None "type" Alpha_context.Script.expr_encoding)
          (Data_encoding.opt None None "gas" Data_encoding.z))
        (Data_encoding.obj2
          (Data_encoding.req None None "packed" Data_encoding.__bytes_value)
          (Data_encoding.req None None "gas" Alpha_context.Gas.encoding))
        (RPC_path.op_div path "pack_data").
    
    Definition run_operation
      : RPC_service.service (* `POST *) unit Updater.rpc_context
        Updater.rpc_context unit
        (Alpha_context.Operation.packed * (|Chain_id|).(S.HASH.t))
        (Alpha_context.Operation.packed_protocol_data *
          Apply_results.packed_operation_metadata) :=
      RPC_service.post_service
        (Some "Run an operation without signature checks") RPC_query.empty
        (Data_encoding.obj2
          (Data_encoding.req None None "operation"
            Alpha_context.Operation.encoding)
          (Data_encoding.req None None "chain_id" (|Chain_id|).(S.HASH.encoding)))
        Apply_results.operation_data_and_metadata_encoding
        (RPC_path.op_div path "run_operation").
    
    Definition entrypoint_type
      : RPC_service.service (* `POST *) unit Updater.rpc_context
        Updater.rpc_context unit (Alpha_context.Script.expr * string)
        Alpha_context.Script.expr :=
      RPC_service.post_service (Some "Return the type of the given entrypoint")
        RPC_query.empty
        (Data_encoding.obj2
          (Data_encoding.req None None "script"
            Alpha_context.Script.expr_encoding)
          (Data_encoding.dft None None "entrypoint" Data_encoding.__string_value
            "default"))
        (Data_encoding.obj1
          (Data_encoding.req None None "entrypoint_type"
            Alpha_context.Script.expr_encoding))
        (RPC_path.op_div path "entrypoint").
    
    Definition list_entrypoints
      : RPC_service.service (* `POST *) unit Updater.rpc_context
        Updater.rpc_context unit Alpha_context.Script.expr
        (list (list Michelson_v1_primitives.prim) *
          list (string * Alpha_context.Script.expr)) :=
      RPC_service.post_service
        (Some "Return the list of entrypoints of the given script")
        RPC_query.empty
        (Data_encoding.obj1
          (Data_encoding.req None None "script"
            Alpha_context.Script.expr_encoding))
        (Data_encoding.obj2
          (Data_encoding.dft None None "unreachable"
            (Data_encoding.__list_value None
              (Data_encoding.obj1
                (Data_encoding.req None None "path"
                  (Data_encoding.__list_value None
                    Michelson_v1_primitives.prim_encoding)))) [])
          (Data_encoding.req None None "entrypoints"
            (Data_encoding.assoc Alpha_context.Script.expr_encoding)))
        (RPC_path.op_div path "entrypoints").
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    let '_ := function_parameter in
    let originate_dummy_contract
      (ctxt : Alpha_context.context) (script : Alpha_context.Script.t)
      : Lwt.t
        (Error_monad.tzresult (Alpha_context.context * Alpha_context.Contract.t)) :=
      let ctxt :=
        Alpha_context.Contract.init_origination_nonce ctxt
          (|Operation_hash|).(S.HASH.zero) in
      Error_monad.op_gtgteqquestion
        (Alpha_context.Contract.fresh_contract_from_current_nonce ctxt)
        (fun function_parameter =>
          let '(ctxt, dummy_contract) := function_parameter in
          let balance :=
            match
              Alpha_context.Tez.of_mutez
                (* ❌ Constant of type int64 is converted to int *)
                4000000000000 with
            | Some balance => balance
            | None =>
              (* ❌ Assert instruction is not handled. *)
              assert false
            end in
          Error_monad.op_gtgteqquestion
            (Alpha_context.Contract.originate ctxt dummy_contract balance
              (script, None) None)
            (fun ctxt => Error_monad.__return (ctxt, dummy_contract))) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    (* ❌ instruction_sequence ";" *)
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    (* ❌ instruction_sequence ";" *)
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    (* ❌ instruction_sequence ";" *)
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    (* ❌ instruction_sequence ";" *)
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    (* ❌ instruction_sequence ";" *)
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    (* ❌ instruction_sequence ";" *)
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    (* ❌ instruction_sequence ";" *)
    Services_registration.register0 S.list_entrypoints
      (fun ctxt =>
        fun function_parameter =>
          let '_ := function_parameter in
          fun expr =>
            let ctxt := Alpha_context.Gas.set_unlimited ctxt in
            let legacy := false in
            Error_monad.op_gtgteqquestion
              (Lwt.__return
                (Error_monad.op_gtgtquestion
                  (Script_ir_translator.parse_toplevel legacy expr)
                  (fun function_parameter =>
                    let '(arg_type, _, _, root_name) := function_parameter in
                    Error_monad.op_gtgtquestion
                      (Script_ir_translator.parse_ty ctxt legacy true false true
                        arg_type)
                      (fun function_parameter =>
                        let '(Script_ir_translator.Ex_ty arg_type, _) :=
                          function_parameter in
                        Script_ir_translator.list_entrypoints arg_type ctxt
                          root_name))))
              (fun function_parameter =>
                let '(unreachable_entrypoint, map) := function_parameter in
                Error_monad.__return
                  (unreachable_entrypoint,
                    ((|Script_ir_translator.Entrypoints_map|).(S.MAP.fold)
                      (fun entry =>
                        fun function_parameter =>
                          let '(_, ty) := function_parameter in
                          fun acc =>
                            cons (entry, (Micheline.strip_locations ty)) acc)
                      map [])))).
  
  Definition run_code {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    (code : Alpha_context.Script.expr)
    (function_parameter :
      Alpha_context.Script.expr * Alpha_context.Script.expr *
        Alpha_context.Tez.t * (|Chain_id|).(S.HASH.t) *
        option Alpha_context.Contract.t * option Alpha_context.Contract.t *
        option Z.t * string)
    : Lwt.t
      (Error_monad.shell_tzresult
        (Alpha_context.Script.expr *
          list Alpha_context.packed_internal_operation *
          option Alpha_context.Contract.big_map_diff)) :=
    let '(storage, input, amount, chain_id, source, payer, gas, entrypoint) :=
      function_parameter in
    RPC_context.make_call0 S.run_code ctxt block tt
      (code, storage, input, amount, chain_id, source, payer, gas, entrypoint).
  
  Definition trace_code {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    (code : Alpha_context.Script.expr)
    (function_parameter :
      Alpha_context.Script.expr * Alpha_context.Script.expr *
        Alpha_context.Tez.t * (|Chain_id|).(S.HASH.t) *
        option Alpha_context.Contract.t * option Alpha_context.Contract.t *
        option Z.t * string)
    : Lwt.t
      (Error_monad.shell_tzresult
        (Alpha_context.Script.expr *
          list Alpha_context.packed_internal_operation *
          list
            (Alpha_context.Script.location * Alpha_context.Gas.t *
              list (Alpha_context.Script.expr * option string)) *
          option Alpha_context.Contract.big_map_diff)) :=
    let '(storage, input, amount, chain_id, source, payer, gas, entrypoint) :=
      function_parameter in
    RPC_context.make_call0 S.trace_code ctxt block tt
      (code, storage, input, amount, chain_id, source, payer, gas, entrypoint).
  
  Definition typecheck_code {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    : Alpha_context.Script.expr * option Z.t ->
    Lwt.t
      (Error_monad.shell_tzresult
        (list
          (Alpha_context.Script.location *
            (list (Alpha_context.Script.expr * list string) *
              list (Alpha_context.Script.expr * list string))) *
          Alpha_context.Gas.t)) :=
    RPC_context.make_call0 S.typecheck_code ctxt block tt.
  
  Definition typecheck_data {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    : Alpha_context.Script.expr * Alpha_context.Script.expr * option Z.t ->
    Lwt.t (Error_monad.shell_tzresult Alpha_context.Gas.t) :=
    RPC_context.make_call0 S.typecheck_data ctxt block tt.
  
  Definition pack_data {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    : Alpha_context.Script.expr * Alpha_context.Script.expr * option Z.t ->
    Lwt.t (Error_monad.shell_tzresult (MBytes.t * Alpha_context.Gas.t)) :=
    RPC_context.make_call0 S.pack_data ctxt block tt.
  
  Definition run_operation {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    : Alpha_context.Operation.packed * (|Chain_id|).(S.HASH.t) ->
    Lwt.t
      (Error_monad.shell_tzresult
        (Alpha_context.Operation.packed_protocol_data *
          Apply_results.packed_operation_metadata)) :=
    RPC_context.make_call0 S.run_operation ctxt block tt.
  
  Definition entrypoint_type {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    : Alpha_context.Script.expr * string ->
    Lwt.t (Error_monad.shell_tzresult Alpha_context.Script.expr) :=
    RPC_context.make_call0 S.entrypoint_type ctxt block tt.
  
  Definition list_entrypoints {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    : Alpha_context.Script.expr ->
    Lwt.t
      (Error_monad.shell_tzresult
        (list (list Michelson_v1_primitives.prim) *
          list (string * Alpha_context.Script.expr))) :=
    RPC_context.make_call0 S.list_entrypoints ctxt block tt.
End Scripts.

Module Forge.
  Module S.
    Import Data_encoding.
    
    Definition path : RPC_path.path Updater.rpc_context Updater.rpc_context :=
      RPC_path.op_div path "forge".
    
    Definition operations
      : RPC_service.service (* `POST *) unit Updater.rpc_context
        Updater.rpc_context unit
        (Operation.shell_header * Alpha_context.packed_contents_list) MBytes.t :=
      RPC_service.post_service (Some "Forge an operation") RPC_query.empty
        Alpha_context.Operation.unsigned_encoding Data_encoding.__bytes_value
        (RPC_path.op_div path "operations").
    
    Definition empty_proof_of_work_nonce : MBytes.t :=
      MBytes.of_string
        (String.make Constants_repr.proof_of_work_nonce_size "000" % char).
    
    Definition protocol_data
      : RPC_service.service (* `POST *) unit Updater.rpc_context
        Updater.rpc_context unit (Z * option Nonce_hash.t * MBytes.t) MBytes.t :=
      RPC_service.post_service
        (Some "Forge the protocol-specific part of a block header")
        RPC_query.empty
        (Data_encoding.obj3
          (Data_encoding.req None None "priority" Data_encoding.uint16)
          (Data_encoding.opt None None "nonce_hash" Nonce_hash.encoding)
          (Data_encoding.dft None None "proof_of_work_nonce"
            (Data_encoding.Fixed.__bytes_value
              Alpha_context.Constants.proof_of_work_nonce_size)
            empty_proof_of_work_nonce))
        (Data_encoding.obj1
          (Data_encoding.req None None "protocol_data"
            Data_encoding.__bytes_value)) (RPC_path.op_div path "protocol_data").
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    let '_ := function_parameter in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    (* ❌ instruction_sequence ";" *)
    Services_registration.register0_noctxt S.protocol_data
      (fun function_parameter =>
        let '_ := function_parameter in
        fun function_parameter =>
          let '(priority, seed_nonce_hash, proof_of_work_nonce) :=
            function_parameter in
          Error_monad.__return
            (Data_encoding.Binary.to_bytes_exn
              Alpha_context.Block_header.contents_encoding
              {| Alpha_context.Block_header.contents.priority := priority;
                Alpha_context.Block_header.contents.seed_nonce_hash :=
                  seed_nonce_hash;
                Alpha_context.Block_header.contents.proof_of_work_nonce :=
                  proof_of_work_nonce |})).
  
  Module Manager.
    Definition operations {D E G I K L a b c i o q : Set}
      (ctxt :
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t RPC_context.t q
          i o -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
          (E * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (RPC_context.t * a) q i o -> D -> a -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
            (((RPC_service.t
              ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
                (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
              ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
            Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
              (((RPC_service.t
                ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
                  (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
                (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c ->
              q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
                (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
      (branch : (|Block_hash|).(S.HASH.t))
      (source : Alpha_context.public_key_hash)
      (sourcePubKey : option (|Signature.Public_key|).(S.SPublic_key.t))
      (counter : Alpha_context.counter) (fee : Alpha_context.Tez.tez)
      (gas_limit : Z.t) (storage_limit : Z.t)
      (operations : list Alpha_context.packed_manager_operation)
      : Lwt.t (Pervasives.result MBytes.t (list Error_monad.shell_error)) :=
      Error_monad.op_gtgteq (Contract_services.manager_key ctxt block source)
        (fun function_parameter =>
          match function_parameter with
          | (Pervasives.Error _) as e => Lwt.__return e
          | Pervasives.Ok revealed =>
            let ops :=
              List.map
                (fun function_parameter =>
                  let 'Alpha_context.Manager operation := function_parameter in
                  Alpha_context.Contents
                    (Alpha_context.Manager_operation
                      {|
                        Alpha_context.contents.Manager_operation.source :=
                          source;
                        Alpha_context.contents.Manager_operation.fee := fee;
                        Alpha_context.contents.Manager_operation.counter :=
                          counter;
                        Alpha_context.contents.Manager_operation.operation :=
                          operation;
                        Alpha_context.contents.Manager_operation.gas_limit :=
                          gas_limit;
                        Alpha_context.contents.Manager_operation.storage_limit :=
                          storage_limit |})) operations in
            let ops :=
              match (sourcePubKey, revealed) with
              | (None, _) | (_, Some _) => ops
              | (Some pk, None) =>
                let operation := Alpha_context.Reveal pk in
                cons
                  (Alpha_context.Contents
                    (Alpha_context.Manager_operation
                      {|
                        Alpha_context.contents.Manager_operation.source :=
                          source;
                        Alpha_context.contents.Manager_operation.fee := fee;
                        Alpha_context.contents.Manager_operation.counter :=
                          counter;
                        Alpha_context.contents.Manager_operation.operation :=
                          operation;
                        Alpha_context.contents.Manager_operation.gas_limit :=
                          gas_limit;
                        Alpha_context.contents.Manager_operation.storage_limit :=
                          storage_limit |})) ops
              end in
            RPC_context.make_call0 S.operations ctxt block tt
              ({| Operation.shell_header.branch := branch |},
                (Alpha_context.Operation.of_list ops))
          end).
    
    Definition reveal {D E G I K L a b c i o q : Set}
      (ctxt :
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t RPC_context.t q
          i o -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
          (E * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (RPC_context.t * a) q i o -> D -> a -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
            (((RPC_service.t
              ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
                (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
              ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
            Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
              (((RPC_service.t
                ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
                  (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
                (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c ->
              q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
                (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
      (branch : (|Block_hash|).(S.HASH.t))
      (source : Alpha_context.public_key_hash)
      (sourcePubKey : (|Signature.Public_key|).(S.SPublic_key.t))
      (counter : Alpha_context.counter) (fee : Alpha_context.Tez.tez)
      (function_parameter : unit)
      : Lwt.t (Pervasives.result MBytes.t (list Error_monad.shell_error)) :=
      let '_ := function_parameter in
      operations ctxt block branch source (Some sourcePubKey) counter fee Z.zero
        Z.zero [].
    
    Definition transaction {D E G I K L a b c i o q : Set}
      (ctxt :
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t RPC_context.t q
          i o -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
          (E * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (RPC_context.t * a) q i o -> D -> a -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
            (((RPC_service.t
              ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
                (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
              ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
            Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
              (((RPC_service.t
                ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
                  (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
                (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c ->
              q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
                (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
      (branch : (|Block_hash|).(S.HASH.t))
      (source : Alpha_context.public_key_hash)
      (sourcePubKey : option (|Signature.Public_key|).(S.SPublic_key.t))
      (counter : Alpha_context.counter) (amount : Alpha_context.Tez.tez)
      (destination : Alpha_context.Contract.contract)
      (op_staroptstar : option string)
      : option Alpha_context.Script.expr -> Z.t -> Z.t ->
      Alpha_context.Tez.tez -> unit ->
      Lwt.t (Pervasives.result MBytes.t (list Error_monad.shell_error)) :=
      let entrypoint :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => "default"
        end in
      fun parameters =>
        fun gas_limit =>
          fun storage_limit =>
            fun fee =>
              fun function_parameter =>
                let '_ := function_parameter in
                let parameters :=
                  Option.unopt_map Alpha_context.Script.__lazy_expr_value
                    Alpha_context.Script.unit_parameter parameters in
                operations ctxt block branch source sourcePubKey counter fee
                  gas_limit storage_limit
                  [
                    Alpha_context.Manager
                      (Alpha_context.Transaction
                        {|
                          Alpha_context.manager_operation.Transaction.amount :=
                            amount;
                          Alpha_context.manager_operation.Transaction.parameters :=
                            parameters;
                          Alpha_context.manager_operation.Transaction.entrypoint :=
                            entrypoint;
                          Alpha_context.manager_operation.Transaction.destination :=
                            destination
                          |})
                  ].
    
    Definition origination {D E G I K L a b c i o q : Set}
      (ctxt :
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t RPC_context.t q
          i o -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
          (E * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (RPC_context.t * a) q i o -> D -> a -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
            (((RPC_service.t
              ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
                (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
              ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
            Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
              (((RPC_service.t
                ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
                  (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
                (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c ->
              q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
                (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
      (branch : (|Block_hash|).(S.HASH.t))
      (source : Alpha_context.public_key_hash)
      (sourcePubKey : option (|Signature.Public_key|).(S.SPublic_key.t))
      (counter : Alpha_context.counter) (balance : Alpha_context.Tez.tez)
      (delegatePubKey :
        option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
      (script : Alpha_context.Script.t) (gas_limit : Z.t) (storage_limit : Z.t)
      (fee : Alpha_context.Tez.tez) (function_parameter : unit)
      : Lwt.t (Pervasives.result MBytes.t (list Error_monad.shell_error)) :=
      let '_ := function_parameter in
      operations ctxt block branch source sourcePubKey counter fee gas_limit
        storage_limit
        [
          Alpha_context.Manager
            (Alpha_context.Origination
              {|
                Alpha_context.manager_operation.Origination.delegate :=
                  delegatePubKey;
                Alpha_context.manager_operation.Origination.script :=
                  script;
                Alpha_context.manager_operation.Origination.credit :=
                  balance;
                Alpha_context.manager_operation.Origination.preorigination :=
                  None |})
        ].
    
    Definition delegation {D E G I K L a b c i o q : Set}
      (ctxt :
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t RPC_context.t q
          i o -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
          (E * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (RPC_context.t * a) q i o -> D -> a -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
            (((RPC_service.t
              ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
                (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
              ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
            Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
              (((RPC_service.t
                ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
                  (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
                (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c ->
              q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
                (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
      (branch : (|Block_hash|).(S.HASH.t))
      (source : Alpha_context.public_key_hash)
      (sourcePubKey : option (|Signature.Public_key|).(S.SPublic_key.t))
      (counter : Alpha_context.counter) (fee : Alpha_context.Tez.tez)
      (delegate : option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
      : Lwt.t (Pervasives.result MBytes.t (list Error_monad.shell_error)) :=
      operations ctxt block branch source sourcePubKey counter fee Z.zero Z.zero
        [ Alpha_context.Manager (Alpha_context.Delegation delegate) ].
  End Manager.
  
  Definition operation {D E G I K L M a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    (branch : (|Block_hash|).(S.HASH.t)) (operation : Alpha_context.contents M)
    : Lwt.t (Error_monad.shell_tzresult MBytes.t) :=
    RPC_context.make_call0 S.operations ctxt block tt
      ({| Operation.shell_header.branch := branch |},
        (Alpha_context.Contents_list (Alpha_context.Single operation))).
  
  Definition endorsement {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (b : D)
    (branch : (|Block_hash|).(S.HASH.t)) (level : Alpha_context.Raw_level.t)
    (function_parameter : unit) : Lwt.t (Error_monad.shell_tzresult MBytes.t) :=
    let '_ := function_parameter in
    operation ctxt b branch
      (Alpha_context.Endorsement
        {| Alpha_context.contents.Endorsement.level := level |}).
  
  Definition proposals {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (b : D)
    (branch : (|Block_hash|).(S.HASH.t))
    (source : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
    (period : Alpha_context.Voting_period.t)
    (proposals : list (|Protocol_hash|).(S.HASH.t)) (function_parameter : unit)
    : Lwt.t (Error_monad.shell_tzresult MBytes.t) :=
    let '_ := function_parameter in
    operation ctxt b branch
      (Alpha_context.Proposals
        {| Alpha_context.contents.Proposals.source := source;
          Alpha_context.contents.Proposals.period := period;
          Alpha_context.contents.Proposals.proposals := proposals |}).
  
  Definition ballot {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (b : D)
    (branch : (|Block_hash|).(S.HASH.t))
    (source : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
    (period : Alpha_context.Voting_period.t)
    (proposal : (|Protocol_hash|).(S.HASH.t))
    (ballot : Alpha_context.Vote.ballot) (function_parameter : unit)
    : Lwt.t (Error_monad.shell_tzresult MBytes.t) :=
    let '_ := function_parameter in
    operation ctxt b branch
      (Alpha_context.Ballot
        {| Alpha_context.contents.Ballot.source := source;
          Alpha_context.contents.Ballot.period := period;
          Alpha_context.contents.Ballot.proposal := proposal;
          Alpha_context.contents.Ballot.ballot := ballot |}).
  
  Definition seed_nonce_revelation {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    (branch : (|Block_hash|).(S.HASH.t)) (level : Alpha_context.Raw_level.t)
    (__nonce_value : Alpha_context.Nonce.t) (function_parameter : unit)
    : Lwt.t (Error_monad.shell_tzresult MBytes.t) :=
    let '_ := function_parameter in
    operation ctxt block branch
      (Alpha_context.Seed_nonce_revelation
        {| Alpha_context.contents.Seed_nonce_revelation.level := level;
          Alpha_context.contents.Seed_nonce_revelation.nonce := __nonce_value |}).
  
  Definition double_baking_evidence {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    (branch : (|Block_hash|).(S.HASH.t)) (bh1 : Alpha_context.Block_header.t)
    (bh2 : Alpha_context.Block_header.t) (function_parameter : unit)
    : Lwt.t (Error_monad.shell_tzresult MBytes.t) :=
    let '_ := function_parameter in
    operation ctxt block branch
      (Alpha_context.Double_baking_evidence
        {| Alpha_context.contents.Double_baking_evidence.bh1 := bh1;
          Alpha_context.contents.Double_baking_evidence.bh2 := bh2 |}).
  
  Definition double_endorsement_evidence {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    (branch : (|Block_hash|).(S.HASH.t))
    (op1 : Alpha_context.operation Alpha_context.Kind.endorsement)
    (op2 : Alpha_context.operation Alpha_context.Kind.endorsement)
    (function_parameter : unit) : Lwt.t (Error_monad.shell_tzresult MBytes.t) :=
    let '_ := function_parameter in
    operation ctxt block branch
      (Alpha_context.Double_endorsement_evidence
        {| Alpha_context.contents.Double_endorsement_evidence.op1 := op1;
          Alpha_context.contents.Double_endorsement_evidence.op2 := op2 |}).
  
  Definition empty_proof_of_work_nonce : MBytes.t :=
    MBytes.of_string
      (String.make Constants_repr.proof_of_work_nonce_size "000" % char).
  
  Definition protocol_data {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    (priority : Z) (seed_nonce_hash : option Nonce_hash.t)
    (op_staroptstar : option MBytes.t)
    : unit -> Lwt.t (Error_monad.shell_tzresult MBytes.t) :=
    let proof_of_work_nonce :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => empty_proof_of_work_nonce
      end in
    fun function_parameter =>
      let '_ := function_parameter in
      RPC_context.make_call0 S.protocol_data ctxt block tt
        (priority, seed_nonce_hash, proof_of_work_nonce).
End Forge.

Module Parse.
  Module S.
    Import Data_encoding.
    
    Definition path : RPC_path.path Updater.rpc_context Updater.rpc_context :=
      RPC_path.op_div path "parse".
    
    Definition operations
      : RPC_service.service (* `POST *) unit Updater.rpc_context
        Updater.rpc_context unit
        (list Alpha_context.Operation.raw * option bool)
        (list Alpha_context.Operation.packed) :=
      RPC_service.post_service (Some "Parse operations") RPC_query.empty
        (Data_encoding.obj2
          (Data_encoding.req None None "operations"
            (Data_encoding.__list_value None
              (Data_encoding.dynamic_size None
                Alpha_context.Operation.raw_encoding)))
          (Data_encoding.opt None None "check_signature"
            Data_encoding.__bool_value))
        (Data_encoding.__list_value None
          (Data_encoding.dynamic_size None Alpha_context.Operation.encoding))
        (RPC_path.op_div path "operations").
    
    Definition block
      : RPC_service.service (* `POST *) unit Updater.rpc_context
        Updater.rpc_context unit Alpha_context.Block_header.raw
        Alpha_context.Block_header.protocol_data :=
      RPC_service.post_service (Some "Parse a block") RPC_query.empty
        Alpha_context.Block_header.raw_encoding
        Alpha_context.Block_header.protocol_data_encoding
        (RPC_path.op_div path "block").
  End S.
  
  Definition parse_protocol_data (protocol_data : MBytes.t)
    : Lwt.t (Error_monad.tzresult Alpha_context.Block_header.protocol_data) :=
    match
      Data_encoding.Binary.of_bytes
        Alpha_context.Block_header.protocol_data_encoding protocol_data with
    | None => Pervasives.failwith "Cant_parse_protocol_data"
    | Some protocol_data => Error_monad.__return protocol_data
    end.
  
  Definition register (function_parameter : unit) : unit :=
    let '_ := function_parameter in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    (* ❌ instruction_sequence ";" *)
    Services_registration.register0_noctxt S.block
      (fun function_parameter =>
        let '_ := function_parameter in
        fun raw_block =>
          parse_protocol_data (Block_header.t.protocol_data raw_block)).
  
  Definition operations {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    (check : option bool) (operations : list Alpha_context.Operation.raw)
    : Lwt.t (Error_monad.shell_tzresult (list Alpha_context.Operation.packed)) :=
    RPC_context.make_call0 S.operations ctxt block tt (operations, check).
  
  Definition block {D E G I K L a b c i o q : Set}
    (ctxt :
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o
      -> D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o))
        *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> D -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (G * a * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
                (* `POST *) unit + (* `PUT *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
    (shell : Block_header.shell_header) (protocol_data : MBytes.t)
    : Lwt.t
      (Error_monad.shell_tzresult Alpha_context.Block_header.protocol_data) :=
    RPC_context.make_call0 S.block ctxt block tt
      {| Block_header.t.shell := shell;
        Block_header.t.protocol_data := protocol_data |}.
End Parse.

Module S.
  Import Data_encoding.
  
  Module level_query.
    Record record := Build {
      offset : int32 }.
    Definition with_offset offset (r : record) :=
      Build offset.
  End level_query.
  Definition level_query := level_query.record.
  
  Definition level_query : RPC_query.t level_query :=
    Pervasives.op_pipegt
      (RPC_query.op_pipeplus
        (RPC_query.__query_value
          (fun offset => {| level_query.offset := offset |}))
        (RPC_query.__field_value None "offset" RPC_arg.__int32_value
          (* ❌ Constant of type int32 is converted to int *)
          0 (fun __t_value => level_query.offset __t_value))) RPC_query.seal.
  
  Definition current_level
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      Updater.rpc_context level_query unit Alpha_context.Level.t :=
    RPC_service.get_service
      (Some
        "Returns the level of the interrogated block, or the one of a block located `offset` blocks after in the chain (or before when negative). For instance, the next block if `offset` is 1.")
      level_query Alpha_context.Level.encoding
      (RPC_path.op_div path "current_level").
  
  Definition levels_in_current_cycle
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      Updater.rpc_context level_query unit
      (Alpha_context.Raw_level.t * Alpha_context.Raw_level.t) :=
    RPC_service.get_service (Some "Levels of a cycle") level_query
      (Data_encoding.obj2
        (Data_encoding.req None None "first" Alpha_context.Raw_level.encoding)
        (Data_encoding.req None None "last" Alpha_context.Raw_level.encoding))
      (RPC_path.op_div path "levels_in_current_cycle").
End S.

Definition register (function_parameter : unit) : unit :=
  let '_ := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  Services_registration.register0 S.levels_in_current_cycle
    (fun ctxt =>
      fun q =>
        fun function_parameter =>
          let '_ := function_parameter in
          let levels :=
            Alpha_context.Level.levels_in_current_cycle ctxt
              (Some (S.level_query.offset q)) tt in
          match levels with
          | [] => Pervasives.raise extensible_type_value
          | _ =>
            let first := List.hd (List.rev levels) in
            let last := List.hd levels in
            Error_monad.__return
              ((Alpha_context.Level.t.level first),
                (Alpha_context.Level.t.level last))
          end).

Definition current_level {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D)
  (op_staroptstar : option int32)
  : D -> Lwt.t (Error_monad.shell_tzresult Alpha_context.Level.t) :=
  let offset :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Constant of type int32 is converted to int *)
      0
    end in
  fun block =>
    RPC_context.make_call0 S.current_level ctxt block
      {| S.level_query.offset := offset |} tt.

Definition levels_in_current_cycle {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D)
  (op_staroptstar : option int32)
  : D ->
  Lwt.t
    (Error_monad.shell_tzresult
      (Alpha_context.Raw_level.t * Alpha_context.Raw_level.t)) :=
  let offset :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Constant of type int32 is converted to int *)
      0
    end in
  fun block =>
    RPC_context.make_call0 S.levels_in_current_cycle ctxt block
      {| S.level_query.offset := offset |} tt.

Helpers_services_mli

  • OCaml size: 271 lines
  • Coq size: 652 lines (+140% compared to OCaml)
helpers_services.mli 313 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

type error += Cannot_parse_operation (* `Branch *)

val current_level :
  'a #RPC_context.simple -> ?offset:int32 -> 'a -> Level.t shell_tzresult Lwt.t

val levels_in_current_cycle :
  'a #RPC_context.simple ->
  ?offset:int32 ->
  'a ->
  (Raw_level.t * Raw_level.t) shell_tzresult Lwt.t

module Scripts : sig
  val run_code :
    'a #RPC_context.simple ->
    'a ->
    Script.expr ->
    Script.expr
    * Script.expr
    * Tez.t
    * Chain_id.t
    * Contract.t option
    * Contract.t option
    * Z.t option
    * string ->
    ( Script.expr
    * packed_internal_operation list
    * Contract.big_map_diff option )
    shell_tzresult
    Lwt.t

  val trace_code :
    'a #RPC_context.simple ->
    'a ->
    Script.expr ->
    Script.expr
    * Script.expr
    * Tez.t
    * Chain_id.t
    * Contract.t option
    * Contract.t option
    * Z.t option
    * string ->
    ( Script.expr
    * packed_internal_operation list
    * Script_interpreter.execution_trace
    * Contract.big_map_diff option )
    shell_tzresult
    Lwt.t

  val typecheck_code :
    'a #RPC_context.simple ->
    'a ->
    Script.expr * Z.t option ->
    (Script_tc_errors.type_map * Gas.t) shell_tzresult Lwt.t

  val typecheck_data :
    'a #RPC_context.simple ->
    'a ->
    Script.expr * Script.expr * Z.t option ->
    Gas.t shell_tzresult Lwt.t

  val pack_data :
    'a #RPC_context.simple ->
    'a ->
    Script.expr * Script.expr * Z.t option ->
    (MBytes.t * Gas.t) shell_tzresult Lwt.t

  val run_operation :
    'a #RPC_context.simple ->
    'a ->
    packed_operation * Chain_id.t ->
    (packed_protocol_data * Apply_results.packed_operation_metadata)
    shell_tzresult
    Lwt.t

  val entrypoint_type :
    'a #RPC_context.simple ->
    'a ->
    Script.expr * string ->
    Script.expr shell_tzresult Lwt.t

  val list_entrypoints :
    'a #RPC_context.simple ->
    'a ->
    Script.expr ->
    (Michelson_v1_primitives.prim list list * (string * Script.expr) list)
    shell_tzresult
    Lwt.t
end

module Forge : sig
  module Manager : sig
    val operations :
      'a #RPC_context.simple ->
      'a ->
      branch:Block_hash.t ->
      source:public_key_hash ->
      ?sourcePubKey:public_key ->
      counter:counter ->
      fee:Tez.t ->
      gas_limit:Z.t ->
      storage_limit:Z.t ->
      packed_manager_operation list ->
      MBytes.t shell_tzresult Lwt.t

    val reveal :
      'a #RPC_context.simple ->
      'a ->
      branch:Block_hash.t ->
      source:public_key_hash ->
      sourcePubKey:public_key ->
      counter:counter ->
      fee:Tez.t ->
      unit ->
      MBytes.t shell_tzresult Lwt.t

    val transaction :
      'a #RPC_context.simple ->
      'a ->
      branch:Block_hash.t ->
      source:public_key_hash ->
      ?sourcePubKey:public_key ->
      counter:counter ->
      amount:Tez.t ->
      destination:Contract.t ->
      ?entrypoint:string ->
      ?parameters:Script.expr ->
      gas_limit:Z.t ->
      storage_limit:Z.t ->
      fee:Tez.t ->
      unit ->
      MBytes.t shell_tzresult Lwt.t

    val origination :
      'a #RPC_context.simple ->
      'a ->
      branch:Block_hash.t ->
      source:public_key_hash ->
      ?sourcePubKey:public_key ->
      counter:counter ->
      balance:Tez.t ->
      ?delegatePubKey:public_key_hash ->
      script:Script.t ->
      gas_limit:Z.t ->
      storage_limit:Z.t ->
      fee:Tez.t ->
      unit ->
      MBytes.t shell_tzresult Lwt.t

    val delegation :
      'a #RPC_context.simple ->
      'a ->
      branch:Block_hash.t ->
      source:public_key_hash ->
      ?sourcePubKey:public_key ->
      counter:counter ->
      fee:Tez.t ->
      public_key_hash option ->
      MBytes.t shell_tzresult Lwt.t
  end

  val endorsement :
    'a #RPC_context.simple ->
    'a ->
    branch:Block_hash.t ->
    level:Raw_level.t ->
    unit ->
    MBytes.t shell_tzresult Lwt.t

  val proposals :
    'a #RPC_context.simple ->
    'a ->
    branch:Block_hash.t ->
    source:public_key_hash ->
    period:Voting_period.t ->
    proposals:Protocol_hash.t list ->
    unit ->
    MBytes.t shell_tzresult Lwt.t

  val ballot :
    'a #RPC_context.simple ->
    'a ->
    branch:Block_hash.t ->
    source:public_key_hash ->
    period:Voting_period.t ->
    proposal:Protocol_hash.t ->
    ballot:Vote.ballot ->
    unit ->
    MBytes.t shell_tzresult Lwt.t

  val seed_nonce_revelation :
    'a #RPC_context.simple ->
    'a ->
    branch:Block_hash.t ->
    level:Raw_level.t ->
    nonce:Nonce.t ->
    unit ->
    MBytes.t shell_tzresult Lwt.t

  val double_baking_evidence :
    'a #RPC_context.simple ->
    'a ->
    branch:Block_hash.t ->
    bh1:Block_header.t ->
    bh2:Block_header.t ->
    unit ->
    MBytes.t shell_tzresult Lwt.t

  val double_endorsement_evidence :
    'a #RPC_context.simple ->
    'a ->
    branch:Block_hash.t ->
    op1:Kind.endorsement operation ->
    op2:Kind.endorsement operation ->
    unit ->
    MBytes.t shell_tzresult Lwt.t

  val protocol_data :
    'a #RPC_context.simple ->
    'a ->
    priority:int ->
    ?seed_nonce_hash:Nonce_hash.t ->
    ?proof_of_work_nonce:MBytes.t ->
    unit ->
    MBytes.t shell_tzresult Lwt.t
end

module Parse : sig
  val operations :
    'a #RPC_context.simple ->
    'a ->
    ?check:bool ->
    Operation.raw list ->
    Operation.packed list shell_tzresult Lwt.t

  val block :
    'a #RPC_context.simple ->
    'a ->
    Block_header.shell_header ->
    MBytes.t ->
    Block_header.protocol_data shell_tzresult Lwt.t
end

val register : unit -> unit
Helpers_services_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Apply_results.
Require Tezos.Michelson_v1_primitives.
Require Tezos.Nonce_hash.
Require Tezos.Script_interpreter.
Require Tezos.Script_tc_errors.

(* extensible_type error *)

Parameter current_level : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> option int32 -> a ->
  Lwt.t (Error_monad.shell_tzresult Alpha_context.Level.t).

Parameter levels_in_current_cycle : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> option int32 -> a ->
  Lwt.t
    (Error_monad.shell_tzresult
      (Alpha_context.Raw_level.t * Alpha_context.Raw_level.t)).

Module Scripts.
  Parameter run_code : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    Alpha_context.Script.expr ->
    Alpha_context.Script.expr * Alpha_context.Script.expr * Alpha_context.Tez.t
      * (|Chain_id|).(S.HASH.t) * option Alpha_context.Contract.t *
      option Alpha_context.Contract.t * option Z.t * string ->
    Lwt.t
      (Error_monad.shell_tzresult
        (Alpha_context.Script.expr *
          list Alpha_context.packed_internal_operation *
          option Alpha_context.Contract.big_map_diff)).
  
  Parameter trace_code : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    Alpha_context.Script.expr ->
    Alpha_context.Script.expr * Alpha_context.Script.expr * Alpha_context.Tez.t
      * (|Chain_id|).(S.HASH.t) * option Alpha_context.Contract.t *
      option Alpha_context.Contract.t * option Z.t * string ->
    Lwt.t
      (Error_monad.shell_tzresult
        (Alpha_context.Script.expr *
          list Alpha_context.packed_internal_operation *
          Script_interpreter.execution_trace *
          option Alpha_context.Contract.big_map_diff)).
  
  Parameter typecheck_code : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    Alpha_context.Script.expr * option Z.t ->
    Lwt.t
      (Error_monad.shell_tzresult
        (Script_tc_errors.type_map * Alpha_context.Gas.t)).
  
  Parameter typecheck_data : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    Alpha_context.Script.expr * Alpha_context.Script.expr * option Z.t ->
    Lwt.t (Error_monad.shell_tzresult Alpha_context.Gas.t).
  
  Parameter pack_data : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    Alpha_context.Script.expr * Alpha_context.Script.expr * option Z.t ->
    Lwt.t (Error_monad.shell_tzresult (MBytes.t * Alpha_context.Gas.t)).
  
  Parameter run_operation : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    Alpha_context.packed_operation * (|Chain_id|).(S.HASH.t) ->
    Lwt.t
      (Error_monad.shell_tzresult
        (Alpha_context.packed_protocol_data *
          Apply_results.packed_operation_metadata)).
  
  Parameter entrypoint_type : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    Alpha_context.Script.expr * string ->
    Lwt.t (Error_monad.shell_tzresult Alpha_context.Script.expr).
  
  Parameter list_entrypoints : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    Alpha_context.Script.expr ->
    Lwt.t
      (Error_monad.shell_tzresult
        (list (list Michelson_v1_primitives.prim) *
          list (string * Alpha_context.Script.expr))).
End Scripts.

Module Forge.
  Module Manager.
    Parameter operations : forall {E F H J K a b c i o q : Set},
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t RPC_context.t q i
        o -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (E * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> a -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
                (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
      (|Block_hash|).(S.HASH.t) -> Alpha_context.public_key_hash ->
      option Alpha_context.public_key -> Alpha_context.counter ->
      Alpha_context.Tez.t -> Z.t -> Z.t ->
      list Alpha_context.packed_manager_operation ->
      Lwt.t (Error_monad.shell_tzresult MBytes.t).
    
    Parameter reveal : forall {E F H J K a b c i o q : Set},
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t RPC_context.t q i
        o -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (E * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> a -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
                (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
      (|Block_hash|).(S.HASH.t) -> Alpha_context.public_key_hash ->
      Alpha_context.public_key -> Alpha_context.counter ->
      Alpha_context.Tez.t -> unit -> Lwt.t (Error_monad.shell_tzresult MBytes.t).
    
    Parameter transaction : forall {E F H J K a b c i o q : Set},
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t RPC_context.t q i
        o -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (E * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> a -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
                (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
      (|Block_hash|).(S.HASH.t) -> Alpha_context.public_key_hash ->
      option Alpha_context.public_key -> Alpha_context.counter ->
      Alpha_context.Tez.t -> Alpha_context.Contract.t -> option string ->
      option Alpha_context.Script.expr -> Z.t -> Z.t -> Alpha_context.Tez.t ->
      unit -> Lwt.t (Error_monad.shell_tzresult MBytes.t).
    
    Parameter origination : forall {E F H J K a b c i o q : Set},
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t RPC_context.t q i
        o -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (E * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> a -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
                (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
      (|Block_hash|).(S.HASH.t) -> Alpha_context.public_key_hash ->
      option Alpha_context.public_key -> Alpha_context.counter ->
      Alpha_context.Tez.t -> option Alpha_context.public_key_hash ->
      Alpha_context.Script.t -> Z.t -> Z.t -> Alpha_context.Tez.t -> unit ->
      Lwt.t (Error_monad.shell_tzresult MBytes.t).
    
    Parameter delegation : forall {E F H J K a b c i o q : Set},
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t RPC_context.t q i
        o -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (E * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (RPC_context.t * a) q i o -> a -> a -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
          Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
            (((RPC_service.t
              ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
                (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
              (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
            i -> Lwt.t (Error_monad.shell_tzresult o)) *
              (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
      (|Block_hash|).(S.HASH.t) -> Alpha_context.public_key_hash ->
      option Alpha_context.public_key -> Alpha_context.counter ->
      Alpha_context.Tez.t -> option Alpha_context.public_key_hash ->
      Lwt.t (Error_monad.shell_tzresult MBytes.t).
  End Manager.
  
  Parameter endorsement : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    (|Block_hash|).(S.HASH.t) -> Alpha_context.Raw_level.t -> unit ->
    Lwt.t (Error_monad.shell_tzresult MBytes.t).
  
  Parameter proposals : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    (|Block_hash|).(S.HASH.t) -> Alpha_context.public_key_hash ->
    Alpha_context.Voting_period.t -> list (|Protocol_hash|).(S.HASH.t) ->
    unit -> Lwt.t (Error_monad.shell_tzresult MBytes.t).
  
  Parameter ballot : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    (|Block_hash|).(S.HASH.t) -> Alpha_context.public_key_hash ->
    Alpha_context.Voting_period.t -> (|Protocol_hash|).(S.HASH.t) ->
    Alpha_context.Vote.ballot -> unit ->
    Lwt.t (Error_monad.shell_tzresult MBytes.t).
  
  Parameter seed_nonce_revelation : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    (|Block_hash|).(S.HASH.t) -> Alpha_context.Raw_level.t ->
    Alpha_context.Nonce.t -> unit -> Lwt.t (Error_monad.shell_tzresult MBytes.t).
  
  Parameter double_baking_evidence : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    (|Block_hash|).(S.HASH.t) -> Alpha_context.Block_header.t ->
    Alpha_context.Block_header.t -> unit ->
    Lwt.t (Error_monad.shell_tzresult MBytes.t).
  
  Parameter double_endorsement_evidence : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    (|Block_hash|).(S.HASH.t) ->
    Alpha_context.operation Alpha_context.Kind.endorsement ->
    Alpha_context.operation Alpha_context.Kind.endorsement -> unit ->
    Lwt.t (Error_monad.shell_tzresult MBytes.t).
  
  Parameter protocol_data : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a -> Z ->
    option Nonce_hash.t -> option MBytes.t -> unit ->
    Lwt.t (Error_monad.shell_tzresult MBytes.t).
End Forge.

Module Parse.
  Parameter operations : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a -> option bool ->
    list Alpha_context.Operation.raw ->
    Lwt.t (Error_monad.shell_tzresult (list Alpha_context.Operation.packed)).
  
  Parameter block : forall {E F H J K a b c i o q : Set},
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
    Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        (RPC_context.t * a) q i o -> a -> a -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
              (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (J * a * b * c * q * i * o)) * K)))) * K * a -> a ->
    Alpha_context.Block_header.shell_header -> MBytes.t ->
    Lwt.t (Error_monad.shell_tzresult Alpha_context.Block_header.protocol_data).
End Parse.

Parameter register : unit -> unit.

Init_storage

  • OCaml size: 61 lines
  • Coq size: 80 lines (+31% compared to OCaml)
init_storage.ml success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* This is the genesis protocol: initialise the state *)
let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness =
  Raw_context.prepare_first_block ~level ~timestamp ~fitness ctxt
  >>=? fun (previous_protocol, ctxt) ->
  Storage.Big_map.Next.init ctxt
  >>=? fun ctxt ->
  match previous_protocol with
  | Genesis param ->
      Commitment_storage.init ctxt param.commitments
      >>=? fun ctxt ->
      Roll_storage.init ctxt
      >>=? fun ctxt ->
      Seed_storage.init ctxt
      >>=? fun ctxt ->
      Contract_storage.init ctxt
      >>=? fun ctxt ->
      Bootstrap_storage.init
        ctxt
        ~typecheck
        ?ramp_up_cycles:param.security_deposit_ramp_up_cycles
        ?no_reward_cycles:param.no_reward_cycles
        param.bootstrap_accounts
        param.bootstrap_contracts
      >>=? fun ctxt ->
      Roll_storage.init_first_cycles ctxt
      >>=? fun ctxt ->
      Vote_storage.init ctxt
      >>=? fun ctxt ->
      Storage.Block_priority.init ctxt 0
      >>=? fun ctxt ->
      Vote_storage.freeze_listings ctxt >>=? fun ctxt -> return ctxt
  | Alpha_previous ->
      return ctxt

let prepare ctxt ~level ~predecessor_timestamp ~timestamp ~fitness =
  Raw_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
Init_storage.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Bootstrap_storage.
Require Tezos.Commitment_storage.
Require Tezos.Contract_storage.
Require Tezos.Parameters_repr.
Require Tezos.Raw_context.
Require Tezos.Roll_storage.
Require Tezos.Script_repr.
Require Tezos.Seed_storage.
Require Tezos.Storage.
Require Tezos.Vote_storage.

Definition prepare_first_block
  (ctxt : Context.t)
  (typecheck :
    Raw_context.t -> Script_repr.t ->
    Lwt.t
      (Error_monad.tzresult
        ((Script_repr.t * option Contract_storage.big_map_diff) * Raw_context.t)))
  (level : int32) (timestamp : Time.t) (fitness : (|Fitness|).(S.T.t))
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Error_monad.op_gtgteqquestion
    (Raw_context.prepare_first_block level timestamp fitness ctxt)
    (fun function_parameter =>
      let '(previous_protocol, ctxt) := function_parameter in
      Error_monad.op_gtgteqquestion (Storage.Big_map.Next.init ctxt)
        (fun ctxt =>
          match previous_protocol with
          | Raw_context.Genesis param =>
            Error_monad.op_gtgteqquestion
              (Commitment_storage.init ctxt
                (Parameters_repr.t.commitments param))
              (fun ctxt =>
                Error_monad.op_gtgteqquestion (Roll_storage.init ctxt)
                  (fun ctxt =>
                    Error_monad.op_gtgteqquestion (Seed_storage.init ctxt)
                      (fun ctxt =>
                        Error_monad.op_gtgteqquestion
                          (Contract_storage.init ctxt)
                          (fun ctxt =>
                            Error_monad.op_gtgteqquestion
                              (Bootstrap_storage.init ctxt typecheck
                                (Parameters_repr.t.security_deposit_ramp_up_cycles
                                  param)
                                (Parameters_repr.t.no_reward_cycles param)
                                (Parameters_repr.t.bootstrap_accounts param)
                                (Parameters_repr.t.bootstrap_contracts param))
                              (fun ctxt =>
                                Error_monad.op_gtgteqquestion
                                  (Roll_storage.init_first_cycles ctxt)
                                  (fun ctxt =>
                                    Error_monad.op_gtgteqquestion
                                      (Vote_storage.init ctxt)
                                      (fun ctxt =>
                                        Error_monad.op_gtgteqquestion
                                          (Storage.Block_priority.init ctxt 0)
                                          (fun ctxt =>
                                            Error_monad.op_gtgteqquestion
                                              (Vote_storage.freeze_listings ctxt)
                                              (fun ctxt =>
                                                Error_monad.__return ctxt)))))))))
          | Raw_context.Alpha_previous => Error_monad.__return ctxt
          end)).

Definition prepare
  (ctxt : Context.t) (level : Int32.t) (predecessor_timestamp : Time.t)
  (timestamp : Time.t) (fitness : (|Fitness|).(S.T.t))
  : Lwt.t (Error_monad.tzresult Raw_context.context) :=
  Raw_context.prepare level predecessor_timestamp timestamp fitness ctxt.

Legacy_script_support_repr

  • OCaml size: 828 lines
  • Coq size: 1350 lines (+63% compared to OCaml)
legacy_script_support_repr.ml success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(* Copyright (c) 2019 Cryptium Labs <contact@cryptium-labs.com>              *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let manager_script_code : Script_repr.lazy_expr =
  let open Micheline in
  let open Michelson_v1_primitives in
  Script_repr.lazy_expr @@ strip_locations
  @@ Seq
       ( 0,
         [ Prim
             ( 0,
               K_parameter,
               [ Prim
                   ( 0,
                     T_or,
                     [ Prim
                         ( 0,
                           T_lambda,
                           [ Prim (0, T_unit, [], []);
                             Prim
                               (0, T_list, [Prim (0, T_operation, [], [])], [])
                           ],
                           ["%do"] );
                       Prim (0, T_unit, [], ["%default"]) ],
                     [] ) ],
               [] );
           Prim (0, K_storage, [Prim (0, T_key_hash, [], [])], []);
           Prim
             ( 0,
               K_code,
               [ Seq
                   ( 0,
                     [ Seq
                         ( 0,
                           [ Seq
                               ( 0,
                                 [ Prim (0, I_DUP, [], []);
                                   Prim (0, I_CAR, [], []);
                                   Prim
                                     ( 0,
                                       I_DIP,
                                       [Seq (0, [Prim (0, I_CDR, [], [])])],
                                       [] ) ] ) ] );
                       Prim
                         ( 0,
                           I_IF_LEFT,
                           [ Seq
                               ( 0,
                                 [ Prim
                                     ( 0,
                                       I_PUSH,
                                       [ Prim (0, T_mutez, [], []);
                                         Int (0, Z.zero) ],
                                       [] );
                                   Prim (0, I_AMOUNT, [], []);
                                   Seq
                                     ( 0,
                                       [ Seq
                                           ( 0,
                                             [ Prim (0, I_COMPARE, [], []);
                                               Prim (0, I_EQ, [], []) ] );
                                         Prim
                                           ( 0,
                                             I_IF,
                                             [ Seq (0, []);
                                               Seq
                                                 ( 0,
                                                   [ Seq
                                                       ( 0,
                                                         [ Prim
                                                             (0, I_UNIT, [], []);
                                                           Prim
                                                             ( 0,
                                                               I_FAILWITH,
                                                               [],
                                                               [] ) ] ) ] ) ],
                                             [] ) ] );
                                   Seq
                                     ( 0,
                                       [ Prim
                                           ( 0,
                                             I_DIP,
                                             [ Seq
                                                 (0, [Prim (0, I_DUP, [], [])])
                                             ],
                                             [] );
                                         Prim (0, I_SWAP, [], []) ] );
                                   Prim (0, I_IMPLICIT_ACCOUNT, [], []);
                                   Prim (0, I_ADDRESS, [], []);
                                   Prim (0, I_SENDER, [], []);
                                   Seq
                                     ( 0,
                                       [ Seq
                                           ( 0,
                                             [ Prim (0, I_COMPARE, [], []);
                                               Prim (0, I_EQ, [], []) ] );
                                         Prim
                                           ( 0,
                                             I_IF,
                                             [ Seq (0, []);
                                               Seq
                                                 ( 0,
                                                   [ Seq
                                                       ( 0,
                                                         [ Prim
                                                             (0, I_UNIT, [], []);
                                                           Prim
                                                             ( 0,
                                                               I_FAILWITH,
                                                               [],
                                                               [] ) ] ) ] ) ],
                                             [] ) ] );
                                   Prim (0, I_UNIT, [], []);
                                   Prim (0, I_EXEC, [], []);
                                   Prim (0, I_PAIR, [], []) ] );
                             Seq
                               ( 0,
                                 [ Prim (0, I_DROP, [], []);
                                   Prim
                                     ( 0,
                                       I_NIL,
                                       [Prim (0, T_operation, [], [])],
                                       [] );
                                   Prim (0, I_PAIR, [], []) ] ) ],
                           [] ) ] ) ],
               [] ) ] )

(* Find the toplevel expression with a given prim type from list,
   because they can be in arbitrary order. *)
let find_toplevel toplevel exprs =
  let open Micheline in
  let rec iter toplevel = function
    | (Prim (_, prim, _, _) as found) :: _
      when String.equal toplevel (Michelson_v1_primitives.string_of_prim prim)
      ->
        Some found
    | _ :: rest ->
        iter toplevel rest
    | [] ->
        None
  in
  iter (Michelson_v1_primitives.string_of_prim toplevel) exprs

let add_do :
    manager_pkh:Signature.Public_key_hash.t ->
    script_code:Script_repr.lazy_expr ->
    script_storage:Script_repr.lazy_expr ->
    (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t =
 fun ~manager_pkh ~script_code ~script_storage ->
  let open Micheline in
  let open Michelson_v1_primitives in
  Lwt.return (Script_repr.force_decode script_code)
  >>=? fun (script_code_expr, _gas_cost) ->
  Lwt.return (Script_repr.force_decode script_storage)
  >>|? fun (script_storage_expr, _gas_cost) ->
  let storage_expr = root script_storage_expr in
  match root script_code_expr with
  | Seq (_, toplevel) -> (
    match
      ( find_toplevel K_parameter toplevel,
        find_toplevel K_storage toplevel,
        find_toplevel K_code toplevel )
    with
    | ( Some
          (Prim
            ( _,
              K_parameter,
              [Prim (_, parameter_type, parameter_expr, parameter_annot)],
              prim_param_annot )),
        Some
          (Prim
            ( _,
              K_storage,
              [ Prim
                  (_, code_storage_type, code_storage_expr, code_storage_annot)
              ],
              k_storage_annot )),
        Some (Prim (_, K_code, [code_expr], code_annot)) ) ->
        (* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *)
        let migrated_code =
          Seq
            ( 0,
              [ Prim
                  ( 0,
                    K_parameter,
                    [ Prim
                        ( 0,
                          T_or,
                          [ Prim
                              ( 0,
                                T_lambda,
                                [ Prim (0, T_unit, [], []);
                                  Prim
                                    ( 0,
                                      T_list,
                                      [Prim (0, T_operation, [], [])],
                                      [] ) ],
                                ["%do"] );
                            Prim
                              ( 0,
                                parameter_type,
                                parameter_expr,
                                "%default" :: parameter_annot ) ],
                          [] ) ],
                    prim_param_annot );
                Prim
                  ( 0,
                    K_storage,
                    [ Prim
                        ( 0,
                          T_pair,
                          [ Prim (0, T_key_hash, [], []);
                            Prim
                              ( 0,
                                code_storage_type,
                                code_storage_expr,
                                code_storage_annot ) ],
                          [] ) ],
                    k_storage_annot );
                Prim
                  ( 0,
                    K_code,
                    [ Seq
                        ( 0,
                          [ Prim (0, I_DUP, [], []);
                            Prim (0, I_CAR, [], []);
                            Prim
                              ( 0,
                                I_IF_LEFT,
                                [ Seq
                                    ( 0,
                                      [ Prim
                                          ( 0,
                                            I_PUSH,
                                            [ Prim (0, T_mutez, [], []);
                                              Int (0, Z.zero) ],
                                            [] );
                                        Prim (0, I_AMOUNT, [], []);
                                        Seq
                                          ( 0,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_COMPARE, [], []);
                                                    Prim (0, I_EQ, [], []) ] );
                                              Prim
                                                ( 0,
                                                  I_IF,
                                                  [ Seq (0, []);
                                                    Seq
                                                      ( 0,
                                                        [ Seq
                                                            ( 0,
                                                              [ Prim
                                                                  ( 0,
                                                                    I_UNIT,
                                                                    [],
                                                                    [] );
                                                                Prim
                                                                  ( 0,
                                                                    I_FAILWITH,
                                                                    [],
                                                                    [] ) ] ) ]
                                                      ) ],
                                                  [] ) ] );
                                        Seq
                                          ( 0,
                                            [ Prim
                                                ( 0,
                                                  I_DIP,
                                                  [ Seq
                                                      ( 0,
                                                        [ Prim
                                                            (0, I_DUP, [], [])
                                                        ] ) ],
                                                  [] );
                                              Prim (0, I_SWAP, [], []) ] );
                                        Prim (0, I_CDR, [], []);
                                        Prim (0, I_CAR, [], []);
                                        Prim (0, I_IMPLICIT_ACCOUNT, [], []);
                                        Prim (0, I_ADDRESS, [], []);
                                        Prim (0, I_SENDER, [], []);
                                        Seq
                                          ( 0,
                                            [ Prim (0, I_COMPARE, [], []);
                                              Prim (0, I_NEQ, [], []);
                                              Prim
                                                ( 0,
                                                  I_IF,
                                                  [ Seq
                                                      ( 0,
                                                        [ Prim
                                                            ( 0,
                                                              I_SENDER,
                                                              [],
                                                              [] );
                                                          Prim
                                                            ( 0,
                                                              I_PUSH,
                                                              [ Prim
                                                                  ( 0,
                                                                    T_string,
                                                                    [],
                                                                    [] );
                                                                String
                                                                  ( 0,
                                                                    "Only the \
                                                                     owner \
                                                                     can \
                                                                     operate."
                                                                  ) ],
                                                              [] );
                                                          Prim
                                                            (0, I_PAIR, [], []);
                                                          Prim
                                                            ( 0,
                                                              I_FAILWITH,
                                                              [],
                                                              [] ) ] );
                                                    Seq
                                                      ( 0,
                                                        [ Prim
                                                            (0, I_UNIT, [], []);
                                                          Prim
                                                            (0, I_EXEC, [], []);
                                                          Prim
                                                            ( 0,
                                                              I_DIP,
                                                              [ Seq
                                                                  ( 0,
                                                                    [ Prim
                                                                        ( 0,
                                                                          I_CDR,
                                                                          [],
                                                                          [] )
                                                                    ] ) ],
                                                              [] );
                                                          Prim
                                                            (0, I_PAIR, [], [])
                                                        ] ) ],
                                                  [] ) ] ) ] );
                                  Seq
                                    ( 0,
                                      [ Prim
                                          ( 0,
                                            I_DIP,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_CDR, [], []);
                                                    Prim (0, I_DUP, [], []);
                                                    Prim (0, I_CDR, [], []) ]
                                                ) ],
                                            [] );
                                        Prim (0, I_PAIR, [], []);
                                        code_expr;
                                        Prim (0, I_SWAP, [], []);
                                        Prim (0, I_CAR, [], []);
                                        Prim (0, I_SWAP, [], []);
                                        Seq
                                          ( 0,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_DUP, [], []);
                                                    Prim (0, I_CAR, [], []);
                                                    Prim
                                                      ( 0,
                                                        I_DIP,
                                                        [ Seq
                                                            ( 0,
                                                              [ Prim
                                                                  ( 0,
                                                                    I_CDR,
                                                                    [],
                                                                    [] ) ] ) ],
                                                        [] ) ] ) ] );
                                        Prim
                                          ( 0,
                                            I_DIP,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_SWAP, [], []);
                                                    Prim (0, I_PAIR, [], []) ]
                                                ) ],
                                            [] );
                                        Prim (0, I_PAIR, [], []) ] ) ],
                                [] ) ] ) ],
                    code_annot ) ] )
        in
        let migrated_storage =
          Prim
            ( 0,
              D_Pair,
              [ (* Instead of
                   `String (0, Signature.Public_key_hash.to_b58check manager_pkh)`
                   the storage is written as unparsed with [Optimized] *)
                Bytes
                  ( 0,
                    Data_encoding.Binary.to_bytes_exn
                      Signature.Public_key_hash.encoding
                      manager_pkh );
                storage_expr ],
              [] )
        in
        ( Script_repr.lazy_expr @@ strip_locations migrated_code,
          Script_repr.lazy_expr @@ strip_locations migrated_storage )
    | _ ->
        (script_code, script_storage) )
  | _ ->
      (script_code, script_storage)

let add_set_delegate :
    manager_pkh:Signature.Public_key_hash.t ->
    script_code:Script_repr.lazy_expr ->
    script_storage:Script_repr.lazy_expr ->
    (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t =
 fun ~manager_pkh ~script_code ~script_storage ->
  let open Micheline in
  let open Michelson_v1_primitives in
  Lwt.return (Script_repr.force_decode script_code)
  >>=? fun (script_code_expr, _gas_cost) ->
  Lwt.return (Script_repr.force_decode script_storage)
  >>|? fun (script_storage_expr, _gas_cost) ->
  let storage_expr = root script_storage_expr in
  match root script_code_expr with
  | Seq (_, toplevel) -> (
    match
      ( find_toplevel K_parameter toplevel,
        find_toplevel K_storage toplevel,
        find_toplevel K_code toplevel )
    with
    | ( Some
          (Prim
            ( _,
              K_parameter,
              [Prim (_, parameter_type, parameter_expr, parameter_annot)],
              prim_param_annot )),
        Some
          (Prim
            ( _,
              K_storage,
              [ Prim
                  (_, code_storage_type, code_storage_expr, code_storage_annot)
              ],
              k_storage_annot )),
        Some (Prim (_, K_code, [code_expr], code_annot)) ) ->
        (* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *)
        let migrated_code =
          Seq
            ( 0,
              [ Prim
                  ( 0,
                    K_parameter,
                    [ Prim
                        ( 0,
                          T_or,
                          [ Prim
                              ( 0,
                                T_or,
                                [ Prim (0, T_key_hash, [], ["%set_delegate"]);
                                  Prim (0, T_unit, [], ["%remove_delegate"]) ],
                                [] );
                            Prim
                              ( 0,
                                parameter_type,
                                parameter_expr,
                                "%default" :: parameter_annot ) ],
                          [] ) ],
                    prim_param_annot );
                Prim
                  ( 0,
                    K_storage,
                    [ Prim
                        ( 0,
                          T_pair,
                          [ Prim (0, T_key_hash, [], []);
                            Prim
                              ( 0,
                                code_storage_type,
                                code_storage_expr,
                                code_storage_annot ) ],
                          [] ) ],
                    k_storage_annot );
                Prim
                  ( 0,
                    K_code,
                    [ Seq
                        ( 0,
                          [ Prim (0, I_DUP, [], []);
                            Prim (0, I_CAR, [], []);
                            Prim
                              ( 0,
                                I_IF_LEFT,
                                [ Seq
                                    ( 0,
                                      [ Prim
                                          ( 0,
                                            I_PUSH,
                                            [ Prim (0, T_mutez, [], []);
                                              Int (0, Z.zero) ],
                                            [] );
                                        Prim (0, I_AMOUNT, [], []);
                                        Seq
                                          ( 0,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_COMPARE, [], []);
                                                    Prim (0, I_EQ, [], []) ] );
                                              Prim
                                                ( 0,
                                                  I_IF,
                                                  [ Seq (0, []);
                                                    Seq
                                                      ( 0,
                                                        [ Seq
                                                            ( 0,
                                                              [ Prim
                                                                  ( 0,
                                                                    I_UNIT,
                                                                    [],
                                                                    [] );
                                                                Prim
                                                                  ( 0,
                                                                    I_FAILWITH,
                                                                    [],
                                                                    [] ) ] ) ]
                                                      ) ],
                                                  [] ) ] );
                                        Seq
                                          ( 0,
                                            [ Prim
                                                ( 0,
                                                  I_DIP,
                                                  [ Seq
                                                      ( 0,
                                                        [ Prim
                                                            (0, I_DUP, [], [])
                                                        ] ) ],
                                                  [] );
                                              Prim (0, I_SWAP, [], []) ] );
                                        Prim (0, I_CDR, [], []);
                                        Prim (0, I_CAR, [], []);
                                        Prim (0, I_IMPLICIT_ACCOUNT, [], []);
                                        Prim (0, I_ADDRESS, [], []);
                                        Prim (0, I_SENDER, [], []);
                                        Seq
                                          ( 0,
                                            [ Prim (0, I_COMPARE, [], []);
                                              Prim (0, I_NEQ, [], []);
                                              Prim
                                                ( 0,
                                                  I_IF,
                                                  [ Seq
                                                      ( 0,
                                                        [ Prim
                                                            ( 0,
                                                              I_SENDER,
                                                              [],
                                                              [] );
                                                          Prim
                                                            ( 0,
                                                              I_PUSH,
                                                              [ Prim
                                                                  ( 0,
                                                                    T_string,
                                                                    [],
                                                                    [] );
                                                                String
                                                                  ( 0,
                                                                    "Only the \
                                                                     owner \
                                                                     can \
                                                                     operate."
                                                                  ) ],
                                                              [] );
                                                          Prim
                                                            (0, I_PAIR, [], []);
                                                          Prim
                                                            ( 0,
                                                              I_FAILWITH,
                                                              [],
                                                              [] ) ] );
                                                    Seq
                                                      ( 0,
                                                        [ Prim
                                                            ( 0,
                                                              I_DIP,
                                                              [ Seq
                                                                  ( 0,
                                                                    [ Prim
                                                                        ( 0,
                                                                          I_CDR,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_NIL,
                                                                          [ Prim
                                                                              ( 
                                                                              0,
                                                                               T_operation,
                                                                               [],
                                                                               []
                                                                              )
                                                                          ],
                                                                          [] )
                                                                    ] ) ],
                                                              [] );
                                                          Prim
                                                            ( 0,
                                                              I_IF_LEFT,
                                                              [ Seq
                                                                  ( 0,
                                                                    [ Prim
                                                                        ( 0,
                                                                          I_SOME,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_SET_DELEGATE,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_CONS,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_PAIR,
                                                                          [],
                                                                          [] )
                                                                    ] );
                                                                Seq
                                                                  ( 0,
                                                                    [ Prim
                                                                        ( 0,
                                                                          I_DROP,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_NONE,
                                                                          [ Prim
                                                                              ( 
                                                                              0,
                                                                               T_key_hash,
                                                                               [],
                                                                               []
                                                                              )
                                                                          ],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_SET_DELEGATE,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_CONS,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_PAIR,
                                                                          [],
                                                                          [] )
                                                                    ] ) ],
                                                              [] ) ] ) ],
                                                  [] ) ] ) ] );
                                  Seq
                                    ( 0,
                                      [ Prim
                                          ( 0,
                                            I_DIP,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_CDR, [], []);
                                                    Prim (0, I_DUP, [], []);
                                                    Prim (0, I_CDR, [], []) ]
                                                ) ],
                                            [] );
                                        Prim (0, I_PAIR, [], []);
                                        code_expr;
                                        Prim (0, I_SWAP, [], []);
                                        Prim (0, I_CAR, [], []);
                                        Prim (0, I_SWAP, [], []);
                                        Seq
                                          ( 0,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_DUP, [], []);
                                                    Prim (0, I_CAR, [], []);
                                                    Prim
                                                      ( 0,
                                                        I_DIP,
                                                        [ Seq
                                                            ( 0,
                                                              [ Prim
                                                                  ( 0,
                                                                    I_CDR,
                                                                    [],
                                                                    [] ) ] ) ],
                                                        [] ) ] ) ] );
                                        Prim
                                          ( 0,
                                            I_DIP,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_SWAP, [], []);
                                                    Prim (0, I_PAIR, [], []) ]
                                                ) ],
                                            [] );
                                        Prim (0, I_PAIR, [], []) ] ) ],
                                [] ) ] ) ],
                    code_annot ) ] )
        in
        let migrated_storage =
          Prim
            ( 0,
              D_Pair,
              [ (* Instead of
                   `String (0, Signature.Public_key_hash.to_b58check manager_pkh)`
                   the storage is written as unparsed with [Optimized] *)
                Bytes
                  ( 0,
                    Data_encoding.Binary.to_bytes_exn
                      Signature.Public_key_hash.encoding
                      manager_pkh );
                storage_expr ],
              [] )
        in
        ( Script_repr.lazy_expr @@ strip_locations migrated_code,
          Script_repr.lazy_expr @@ strip_locations migrated_storage )
    | _ ->
        (script_code, script_storage) )
  | _ ->
      (script_code, script_storage)

let has_default_entrypoint expr =
  let open Micheline in
  let open Michelson_v1_primitives in
  match Script_repr.force_decode expr with
  | Error _ ->
      false
  | Ok (expr, _) -> (
    match root expr with
    | Seq (_, toplevel) -> (
      match find_toplevel K_parameter toplevel with
      | Some (Prim (_, K_parameter, [_], ["%default"])) ->
          false
      | Some (Prim (_, K_parameter, [parameter_expr], _)) ->
          let rec has_default = function
            | Prim (_, T_or, [l; r], annots) ->
                List.exists (String.equal "%default") annots
                || has_default l || has_default r
            | Prim (_, _, _, annots) ->
                List.exists (String.equal "%default") annots
            | _ ->
                false
          in
          has_default parameter_expr
      | Some _ | None ->
          false )
    | _ ->
        false )

let add_root_entrypoint :
    script_code:Script_repr.lazy_expr -> Script_repr.lazy_expr tzresult Lwt.t =
 fun ~script_code ->
  let open Micheline in
  let open Michelson_v1_primitives in
  Lwt.return (Script_repr.force_decode script_code)
  >>|? fun (script_code_expr, _gas_cost) ->
  match root script_code_expr with
  | Seq (_, toplevel) ->
      let migrated_code =
        Seq
          ( 0,
            List.map
              (function
                | Prim (_, K_parameter, [parameter_expr], _) ->
                    Prim (0, K_parameter, [parameter_expr], ["%root"])
                | Prim (_, K_code, exprs, annots) ->
                    let rec rewrite_self = function
                      | ( Int _
                        | String _
                        | Bytes _
                        | Prim (_, I_CREATE_CONTRACT, _, _) ) as leaf ->
                          leaf
                      | Prim (_, I_SELF, [], annots) ->
                          Prim (0, I_SELF, [], "%root" :: annots)
                      | Prim (_, name, args, annots) ->
                          Prim (0, name, List.map rewrite_self args, annots)
                      | Seq (_, args) ->
                          Seq (0, List.map rewrite_self args)
                    in
                    Prim (0, K_code, List.map rewrite_self exprs, annots)
                | other ->
                    other)
              toplevel )
      in
      Script_repr.lazy_expr @@ strip_locations migrated_code
  | _ ->
      script_code
Legacy_script_support_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Michelson_v1_primitives.
Require Tezos.Script_repr.

Definition manager_script_code : Script_repr.lazy_expr :=
  Pervasives.op_atat Script_repr.__lazy_expr_value
    (Pervasives.op_atat Micheline.strip_locations
      (Micheline.Seq 0
        [
          Micheline.Prim 0 Michelson_v1_primitives.K_parameter
            [
              Micheline.Prim 0 Michelson_v1_primitives.T_or
                [
                  Micheline.Prim 0
                    Michelson_v1_primitives.T_lambda
                    [
                      Micheline.Prim
                        0
                        Michelson_v1_primitives.T_unit
                        []
                        [];
                      Micheline.Prim
                        0
                        Michelson_v1_primitives.T_list
                        [
                          Micheline.Prim
                            0
                            Michelson_v1_primitives.T_operation
                            []
                            []
                        ]
                        []
                    ]
                    [
                      "%do"
                    ];
                  Micheline.Prim 0
                    Michelson_v1_primitives.T_unit
                    []
                    [
                      "%default"
                    ]
                ] []
            ] [];
          Micheline.Prim 0 Michelson_v1_primitives.K_storage
            [ Micheline.Prim 0 Michelson_v1_primitives.T_key_hash [] [] ]
            [];
          Micheline.Prim 0 Michelson_v1_primitives.K_code
            [
              Micheline.Seq 0
                [
                  Micheline.Seq 0
                    [
                      Micheline.Seq
                        0
                        [
                          Micheline.Prim
                            0
                            Michelson_v1_primitives.I_DUP
                            []
                            [];
                          Micheline.Prim
                            0
                            Michelson_v1_primitives.I_CAR
                            []
                            [];
                          Micheline.Prim
                            0
                            Michelson_v1_primitives.I_DIP
                            [
                              Micheline.Seq
                                0
                                [
                                  Micheline.Prim
                                    0
                                    Michelson_v1_primitives.I_CDR
                                    []
                                    []
                                ]
                            ]
                            []
                        ]
                    ];
                  Micheline.Prim 0
                    Michelson_v1_primitives.I_IF_LEFT
                    [
                      Micheline.Seq
                        0
                        [
                          Micheline.Prim
                            0
                            Michelson_v1_primitives.I_PUSH
                            [
                              Micheline.Prim
                                0
                                Michelson_v1_primitives.T_mutez
                                []
                                [];
                              Micheline.Int
                                0
                                Z.zero
                            ]
                            [];
                          Micheline.Prim
                            0
                            Michelson_v1_primitives.I_AMOUNT
                            []
                            [];
                          Micheline.Seq
                            0
                            [
                              Micheline.Seq
                                0
                                [
                                  Micheline.Prim
                                    0
                                    Michelson_v1_primitives.I_COMPARE
                                    []
                                    [];
                                  Micheline.Prim
                                    0
                                    Michelson_v1_primitives.I_EQ
                                    []
                                    []
                                ];
                              Micheline.Prim
                                0
                                Michelson_v1_primitives.I_IF
                                [
                                  Micheline.Seq
                                    0
                                    [];
                                  Micheline.Seq
                                    0
                                    [
                                      Micheline.Seq
                                        0
                                        [
                                          Micheline.Prim
                                            0
                                            Michelson_v1_primitives.I_UNIT
                                            []
                                            [];
                                          Micheline.Prim
                                            0
                                            Michelson_v1_primitives.I_FAILWITH
                                            []
                                            []
                                        ]
                                    ]
                                ]
                                []
                            ];
                          Micheline.Seq
                            0
                            [
                              Micheline.Prim
                                0
                                Michelson_v1_primitives.I_DIP
                                [
                                  Micheline.Seq
                                    0
                                    [
                                      Micheline.Prim
                                        0
                                        Michelson_v1_primitives.I_DUP
                                        []
                                        []
                                    ]
                                ]
                                [];
                              Micheline.Prim
                                0
                                Michelson_v1_primitives.I_SWAP
                                []
                                []
                            ];
                          Micheline.Prim
                            0
                            Michelson_v1_primitives.I_IMPLICIT_ACCOUNT
                            []
                            [];
                          Micheline.Prim
                            0
                            Michelson_v1_primitives.I_ADDRESS
                            []
                            [];
                          Micheline.Prim
                            0
                            Michelson_v1_primitives.I_SENDER
                            []
                            [];
                          Micheline.Seq
                            0
                            [
                              Micheline.Seq
                                0
                                [
                                  Micheline.Prim
                                    0
                                    Michelson_v1_primitives.I_COMPARE
                                    []
                                    [];
                                  Micheline.Prim
                                    0
                                    Michelson_v1_primitives.I_EQ
                                    []
                                    []
                                ];
                              Micheline.Prim
                                0
                                Michelson_v1_primitives.I_IF
                                [
                                  Micheline.Seq
                                    0
                                    [];
                                  Micheline.Seq
                                    0
                                    [
                                      Micheline.Seq
                                        0
                                        [
                                          Micheline.Prim
                                            0
                                            Michelson_v1_primitives.I_UNIT
                                            []
                                            [];
                                          Micheline.Prim
                                            0
                                            Michelson_v1_primitives.I_FAILWITH
                                            []
                                            []
                                        ]
                                    ]
                                ]
                                []
                            ];
                          Micheline.Prim
                            0
                            Michelson_v1_primitives.I_UNIT
                            []
                            [];
                          Micheline.Prim
                            0
                            Michelson_v1_primitives.I_EXEC
                            []
                            [];
                          Micheline.Prim
                            0
                            Michelson_v1_primitives.I_PAIR
                            []
                            []
                        ];
                      Micheline.Seq
                        0
                        [
                          Micheline.Prim
                            0
                            Michelson_v1_primitives.I_DROP
                            []
                            [];
                          Micheline.Prim
                            0
                            Michelson_v1_primitives.I_NIL
                            [
                              Micheline.Prim
                                0
                                Michelson_v1_primitives.T_operation
                                []
                                []
                            ]
                            [];
                          Micheline.Prim
                            0
                            Michelson_v1_primitives.I_PAIR
                            []
                            []
                        ]
                    ]
                    []
                ]
            ] []
        ])).

Definition find_toplevel {A : Set}
  (toplevel : Michelson_v1_primitives.prim)
  (exprs : list (Micheline.node A Michelson_v1_primitives.prim))
  : option (Micheline.node A Michelson_v1_primitives.prim) :=
  let fix iter {B : Set}
    (toplevel : String.t)
    (function_parameter : list (Micheline.node B Michelson_v1_primitives.prim))
    {struct toplevel}
    : option (Micheline.node B Michelson_v1_primitives.prim) :=
    match
      (function_parameter,
        match function_parameter with
        | cons ((Micheline.Prim _ prim _ _) as found) _ =>
          String.equal toplevel (Michelson_v1_primitives.string_of_prim prim)
        | _ => false
        end) with
    | (cons ((Micheline.Prim _ prim _ _) as found) _, true) => Some found
    | (cons _ rest, _) => iter toplevel rest
    | ([], _) => None
    end in
  iter (Michelson_v1_primitives.string_of_prim toplevel) exprs.

Definition add_do
  (manager_pkh : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (script_code : Script_repr.lazy_expr) (script_storage : Script_repr.lazy_expr)
  : Lwt.t (Error_monad.tzresult (Script_repr.lazy_expr * Script_repr.lazy_expr)) :=
  Error_monad.op_gtgteqquestion
    (Lwt.__return (Script_repr.force_decode script_code))
    (fun function_parameter =>
      let '(script_code_expr, _gas_cost) := function_parameter in
      Error_monad.op_gtgtpipequestion
        (Lwt.__return (Script_repr.force_decode script_storage))
        (fun function_parameter =>
          let '(script_storage_expr, _gas_cost) := function_parameter in
          let storage_expr := Micheline.root script_storage_expr in
          match Micheline.root script_code_expr with
          | Micheline.Seq _ toplevel =>
            match
              ((find_toplevel Michelson_v1_primitives.K_parameter toplevel),
                (find_toplevel Michelson_v1_primitives.K_storage toplevel),
                (find_toplevel Michelson_v1_primitives.K_code toplevel)) with
            |
              (Some
                (Micheline.Prim _ Michelson_v1_primitives.K_parameter
                  (cons
                    (Micheline.Prim _ parameter_type parameter_expr
                      parameter_annot) []) prim_param_annot),
                Some
                  (Micheline.Prim _ Michelson_v1_primitives.K_storage
                    (cons
                      (Micheline.Prim _ code_storage_type code_storage_expr
                        code_storage_annot) []) k_storage_annot),
                Some
                  (Micheline.Prim _ Michelson_v1_primitives.K_code
                    (cons code_expr []) code_annot)) =>
              let migrated_code :=
                Micheline.Seq 0
                  [
                    Micheline.Prim 0 Michelson_v1_primitives.K_parameter
                      [
                        Micheline.Prim 0
                          Michelson_v1_primitives.T_or
                          [
                            Micheline.Prim
                              0
                              Michelson_v1_primitives.T_lambda
                              [
                                Micheline.Prim
                                  0
                                  Michelson_v1_primitives.T_unit
                                  []
                                  [];
                                Micheline.Prim
                                  0
                                  Michelson_v1_primitives.T_list
                                  [
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.T_operation
                                      []
                                      []
                                  ]
                                  []
                              ]
                              [
                                "%do"
                              ];
                            Micheline.Prim
                              0
                              parameter_type
                              parameter_expr
                              (cons
                                "%default"
                                parameter_annot)
                          ]
                          []
                      ] prim_param_annot;
                    Micheline.Prim 0 Michelson_v1_primitives.K_storage
                      [
                        Micheline.Prim 0
                          Michelson_v1_primitives.T_pair
                          [
                            Micheline.Prim
                              0
                              Michelson_v1_primitives.T_key_hash
                              []
                              [];
                            Micheline.Prim
                              0
                              code_storage_type
                              code_storage_expr
                              code_storage_annot
                          ]
                          []
                      ] k_storage_annot;
                    Micheline.Prim 0 Michelson_v1_primitives.K_code
                      [
                        Micheline.Seq 0
                          [
                            Micheline.Prim
                              0
                              Michelson_v1_primitives.I_DUP
                              []
                              [];
                            Micheline.Prim
                              0
                              Michelson_v1_primitives.I_CAR
                              []
                              [];
                            Micheline.Prim
                              0
                              Michelson_v1_primitives.I_IF_LEFT
                              [
                                Micheline.Seq
                                  0
                                  [
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_PUSH
                                      [
                                        Micheline.Prim
                                          0
                                          Michelson_v1_primitives.T_mutez
                                          []
                                          [];
                                        Micheline.Int
                                          0
                                          Z.zero
                                      ]
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_AMOUNT
                                      []
                                      [];
                                    Micheline.Seq
                                      0
                                      [
                                        Micheline.Seq
                                          0
                                          [
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_COMPARE
                                              []
                                              [];
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_EQ
                                              []
                                              []
                                          ];
                                        Micheline.Prim
                                          0
                                          Michelson_v1_primitives.I_IF
                                          [
                                            Micheline.Seq
                                              0
                                              [];
                                            Micheline.Seq
                                              0
                                              [
                                                Micheline.Seq
                                                  0
                                                  [
                                                    Micheline.Prim
                                                      0
                                                      Michelson_v1_primitives.I_UNIT
                                                      []
                                                      [];
                                                    Micheline.Prim
                                                      0
                                                      Michelson_v1_primitives.I_FAILWITH
                                                      []
                                                      []
                                                  ]
                                              ]
                                          ]
                                          []
                                      ];
                                    Micheline.Seq
                                      0
                                      [
                                        Micheline.Prim
                                          0
                                          Michelson_v1_primitives.I_DIP
                                          [
                                            Micheline.Seq
                                              0
                                              [
                                                Micheline.Prim
                                                  0
                                                  Michelson_v1_primitives.I_DUP
                                                  []
                                                  []
                                              ]
                                          ]
                                          [];
                                        Micheline.Prim
                                          0
                                          Michelson_v1_primitives.I_SWAP
                                          []
                                          []
                                      ];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_CDR
                                      []
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_CAR
                                      []
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_IMPLICIT_ACCOUNT
                                      []
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_ADDRESS
                                      []
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_SENDER
                                      []
                                      [];
                                    Micheline.Seq
                                      0
                                      [
                                        Micheline.Prim
                                          0
                                          Michelson_v1_primitives.I_COMPARE
                                          []
                                          [];
                                        Micheline.Prim
                                          0
                                          Michelson_v1_primitives.I_NEQ
                                          []
                                          [];
                                        Micheline.Prim
                                          0
                                          Michelson_v1_primitives.I_IF
                                          [
                                            Micheline.Seq
                                              0
                                              [
                                                Micheline.Prim
                                                  0
                                                  Michelson_v1_primitives.I_SENDER
                                                  []
                                                  [];
                                                Micheline.Prim
                                                  0
                                                  Michelson_v1_primitives.I_PUSH
                                                  [
                                                    Micheline.Prim
                                                      0
                                                      Michelson_v1_primitives.T_string
                                                      []
                                                      [];
                                                    Micheline.String
                                                      0
                                                      "Only the owner can operate."
                                                  ]
                                                  [];
                                                Micheline.Prim
                                                  0
                                                  Michelson_v1_primitives.I_PAIR
                                                  []
                                                  [];
                                                Micheline.Prim
                                                  0
                                                  Michelson_v1_primitives.I_FAILWITH
                                                  []
                                                  []
                                              ];
                                            Micheline.Seq
                                              0
                                              [
                                                Micheline.Prim
                                                  0
                                                  Michelson_v1_primitives.I_UNIT
                                                  []
                                                  [];
                                                Micheline.Prim
                                                  0
                                                  Michelson_v1_primitives.I_EXEC
                                                  []
                                                  [];
                                                Micheline.Prim
                                                  0
                                                  Michelson_v1_primitives.I_DIP
                                                  [
                                                    Micheline.Seq
                                                      0
                                                      [
                                                        Micheline.Prim
                                                          0
                                                          Michelson_v1_primitives.I_CDR
                                                          []
                                                          []
                                                      ]
                                                  ]
                                                  [];
                                                Micheline.Prim
                                                  0
                                                  Michelson_v1_primitives.I_PAIR
                                                  []
                                                  []
                                              ]
                                          ]
                                          []
                                      ]
                                  ];
                                Micheline.Seq
                                  0
                                  [
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_DIP
                                      [
                                        Micheline.Seq
                                          0
                                          [
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_CDR
                                              []
                                              [];
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_DUP
                                              []
                                              [];
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_CDR
                                              []
                                              []
                                          ]
                                      ]
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_PAIR
                                      []
                                      [];
                                    code_expr;
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_SWAP
                                      []
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_CAR
                                      []
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_SWAP
                                      []
                                      [];
                                    Micheline.Seq
                                      0
                                      [
                                        Micheline.Seq
                                          0
                                          [
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_DUP
                                              []
                                              [];
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_CAR
                                              []
                                              [];
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_DIP
                                              [
                                                Micheline.Seq
                                                  0
                                                  [
                                                    Micheline.Prim
                                                      0
                                                      Michelson_v1_primitives.I_CDR
                                                      []
                                                      []
                                                  ]
                                              ]
                                              []
                                          ]
                                      ];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_DIP
                                      [
                                        Micheline.Seq
                                          0
                                          [
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_SWAP
                                              []
                                              [];
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_PAIR
                                              []
                                              []
                                          ]
                                      ]
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_PAIR
                                      []
                                      []
                                  ]
                              ]
                              []
                          ]
                      ] code_annot
                  ] in
              let migrated_storage :=
                Micheline.Prim 0 Michelson_v1_primitives.D_Pair
                  [
                    Micheline.Bytes 0
                      (Data_encoding.Binary.to_bytes_exn
                        (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding)
                        manager_pkh);
                    storage_expr
                  ] [] in
              ((Pervasives.op_atat Script_repr.__lazy_expr_value
                (Micheline.strip_locations migrated_code)),
                (Pervasives.op_atat Script_repr.__lazy_expr_value
                  (Micheline.strip_locations migrated_storage)))
            | _ => (script_code, script_storage)
            end
          | _ => (script_code, script_storage)
          end)).

Definition add_set_delegate
  (manager_pkh : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  (script_code : Script_repr.lazy_expr) (script_storage : Script_repr.lazy_expr)
  : Lwt.t (Error_monad.tzresult (Script_repr.lazy_expr * Script_repr.lazy_expr)) :=
  Error_monad.op_gtgteqquestion
    (Lwt.__return (Script_repr.force_decode script_code))
    (fun function_parameter =>
      let '(script_code_expr, _gas_cost) := function_parameter in
      Error_monad.op_gtgtpipequestion
        (Lwt.__return (Script_repr.force_decode script_storage))
        (fun function_parameter =>
          let '(script_storage_expr, _gas_cost) := function_parameter in
          let storage_expr := Micheline.root script_storage_expr in
          match Micheline.root script_code_expr with
          | Micheline.Seq _ toplevel =>
            match
              ((find_toplevel Michelson_v1_primitives.K_parameter toplevel),
                (find_toplevel Michelson_v1_primitives.K_storage toplevel),
                (find_toplevel Michelson_v1_primitives.K_code toplevel)) with
            |
              (Some
                (Micheline.Prim _ Michelson_v1_primitives.K_parameter
                  (cons
                    (Micheline.Prim _ parameter_type parameter_expr
                      parameter_annot) []) prim_param_annot),
                Some
                  (Micheline.Prim _ Michelson_v1_primitives.K_storage
                    (cons
                      (Micheline.Prim _ code_storage_type code_storage_expr
                        code_storage_annot) []) k_storage_annot),
                Some
                  (Micheline.Prim _ Michelson_v1_primitives.K_code
                    (cons code_expr []) code_annot)) =>
              let migrated_code :=
                Micheline.Seq 0
                  [
                    Micheline.Prim 0 Michelson_v1_primitives.K_parameter
                      [
                        Micheline.Prim 0
                          Michelson_v1_primitives.T_or
                          [
                            Micheline.Prim
                              0
                              Michelson_v1_primitives.T_or
                              [
                                Micheline.Prim
                                  0
                                  Michelson_v1_primitives.T_key_hash
                                  []
                                  [
                                    "%set_delegate"
                                  ];
                                Micheline.Prim
                                  0
                                  Michelson_v1_primitives.T_unit
                                  []
                                  [
                                    "%remove_delegate"
                                  ]
                              ]
                              [];
                            Micheline.Prim
                              0
                              parameter_type
                              parameter_expr
                              (cons
                                "%default"
                                parameter_annot)
                          ]
                          []
                      ] prim_param_annot;
                    Micheline.Prim 0 Michelson_v1_primitives.K_storage
                      [
                        Micheline.Prim 0
                          Michelson_v1_primitives.T_pair
                          [
                            Micheline.Prim
                              0
                              Michelson_v1_primitives.T_key_hash
                              []
                              [];
                            Micheline.Prim
                              0
                              code_storage_type
                              code_storage_expr
                              code_storage_annot
                          ]
                          []
                      ] k_storage_annot;
                    Micheline.Prim 0 Michelson_v1_primitives.K_code
                      [
                        Micheline.Seq 0
                          [
                            Micheline.Prim
                              0
                              Michelson_v1_primitives.I_DUP
                              []
                              [];
                            Micheline.Prim
                              0
                              Michelson_v1_primitives.I_CAR
                              []
                              [];
                            Micheline.Prim
                              0
                              Michelson_v1_primitives.I_IF_LEFT
                              [
                                Micheline.Seq
                                  0
                                  [
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_PUSH
                                      [
                                        Micheline.Prim
                                          0
                                          Michelson_v1_primitives.T_mutez
                                          []
                                          [];
                                        Micheline.Int
                                          0
                                          Z.zero
                                      ]
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_AMOUNT
                                      []
                                      [];
                                    Micheline.Seq
                                      0
                                      [
                                        Micheline.Seq
                                          0
                                          [
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_COMPARE
                                              []
                                              [];
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_EQ
                                              []
                                              []
                                          ];
                                        Micheline.Prim
                                          0
                                          Michelson_v1_primitives.I_IF
                                          [
                                            Micheline.Seq
                                              0
                                              [];
                                            Micheline.Seq
                                              0
                                              [
                                                Micheline.Seq
                                                  0
                                                  [
                                                    Micheline.Prim
                                                      0
                                                      Michelson_v1_primitives.I_UNIT
                                                      []
                                                      [];
                                                    Micheline.Prim
                                                      0
                                                      Michelson_v1_primitives.I_FAILWITH
                                                      []
                                                      []
                                                  ]
                                              ]
                                          ]
                                          []
                                      ];
                                    Micheline.Seq
                                      0
                                      [
                                        Micheline.Prim
                                          0
                                          Michelson_v1_primitives.I_DIP
                                          [
                                            Micheline.Seq
                                              0
                                              [
                                                Micheline.Prim
                                                  0
                                                  Michelson_v1_primitives.I_DUP
                                                  []
                                                  []
                                              ]
                                          ]
                                          [];
                                        Micheline.Prim
                                          0
                                          Michelson_v1_primitives.I_SWAP
                                          []
                                          []
                                      ];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_CDR
                                      []
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_CAR
                                      []
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_IMPLICIT_ACCOUNT
                                      []
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_ADDRESS
                                      []
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_SENDER
                                      []
                                      [];
                                    Micheline.Seq
                                      0
                                      [
                                        Micheline.Prim
                                          0
                                          Michelson_v1_primitives.I_COMPARE
                                          []
                                          [];
                                        Micheline.Prim
                                          0
                                          Michelson_v1_primitives.I_NEQ
                                          []
                                          [];
                                        Micheline.Prim
                                          0
                                          Michelson_v1_primitives.I_IF
                                          [
                                            Micheline.Seq
                                              0
                                              [
                                                Micheline.Prim
                                                  0
                                                  Michelson_v1_primitives.I_SENDER
                                                  []
                                                  [];
                                                Micheline.Prim
                                                  0
                                                  Michelson_v1_primitives.I_PUSH
                                                  [
                                                    Micheline.Prim
                                                      0
                                                      Michelson_v1_primitives.T_string
                                                      []
                                                      [];
                                                    Micheline.String
                                                      0
                                                      "Only the owner can operate."
                                                  ]
                                                  [];
                                                Micheline.Prim
                                                  0
                                                  Michelson_v1_primitives.I_PAIR
                                                  []
                                                  [];
                                                Micheline.Prim
                                                  0
                                                  Michelson_v1_primitives.I_FAILWITH
                                                  []
                                                  []
                                              ];
                                            Micheline.Seq
                                              0
                                              [
                                                Micheline.Prim
                                                  0
                                                  Michelson_v1_primitives.I_DIP
                                                  [
                                                    Micheline.Seq
                                                      0
                                                      [
                                                        Micheline.Prim
                                                          0
                                                          Michelson_v1_primitives.I_CDR
                                                          []
                                                          [];
                                                        Micheline.Prim
                                                          0
                                                          Michelson_v1_primitives.I_NIL
                                                          [
                                                            Micheline.Prim
                                                              0
                                                              Michelson_v1_primitives.T_operation
                                                              []
                                                              []
                                                          ]
                                                          []
                                                      ]
                                                  ]
                                                  [];
                                                Micheline.Prim
                                                  0
                                                  Michelson_v1_primitives.I_IF_LEFT
                                                  [
                                                    Micheline.Seq
                                                      0
                                                      [
                                                        Micheline.Prim
                                                          0
                                                          Michelson_v1_primitives.I_SOME
                                                          []
                                                          [];
                                                        Micheline.Prim
                                                          0
                                                          Michelson_v1_primitives.I_SET_DELEGATE
                                                          []
                                                          [];
                                                        Micheline.Prim
                                                          0
                                                          Michelson_v1_primitives.I_CONS
                                                          []
                                                          [];
                                                        Micheline.Prim
                                                          0
                                                          Michelson_v1_primitives.I_PAIR
                                                          []
                                                          []
                                                      ];
                                                    Micheline.Seq
                                                      0
                                                      [
                                                        Micheline.Prim
                                                          0
                                                          Michelson_v1_primitives.I_DROP
                                                          []
                                                          [];
                                                        Micheline.Prim
                                                          0
                                                          Michelson_v1_primitives.I_NONE
                                                          [
                                                            Micheline.Prim
                                                              0
                                                              Michelson_v1_primitives.T_key_hash
                                                              []
                                                              []
                                                          ]
                                                          [];
                                                        Micheline.Prim
                                                          0
                                                          Michelson_v1_primitives.I_SET_DELEGATE
                                                          []
                                                          [];
                                                        Micheline.Prim
                                                          0
                                                          Michelson_v1_primitives.I_CONS
                                                          []
                                                          [];
                                                        Micheline.Prim
                                                          0
                                                          Michelson_v1_primitives.I_PAIR
                                                          []
                                                          []
                                                      ]
                                                  ]
                                                  []
                                              ]
                                          ]
                                          []
                                      ]
                                  ];
                                Micheline.Seq
                                  0
                                  [
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_DIP
                                      [
                                        Micheline.Seq
                                          0
                                          [
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_CDR
                                              []
                                              [];
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_DUP
                                              []
                                              [];
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_CDR
                                              []
                                              []
                                          ]
                                      ]
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_PAIR
                                      []
                                      [];
                                    code_expr;
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_SWAP
                                      []
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_CAR
                                      []
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_SWAP
                                      []
                                      [];
                                    Micheline.Seq
                                      0
                                      [
                                        Micheline.Seq
                                          0
                                          [
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_DUP
                                              []
                                              [];
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_CAR
                                              []
                                              [];
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_DIP
                                              [
                                                Micheline.Seq
                                                  0
                                                  [
                                                    Micheline.Prim
                                                      0
                                                      Michelson_v1_primitives.I_CDR
                                                      []
                                                      []
                                                  ]
                                              ]
                                              []
                                          ]
                                      ];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_DIP
                                      [
                                        Micheline.Seq
                                          0
                                          [
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_SWAP
                                              []
                                              [];
                                            Micheline.Prim
                                              0
                                              Michelson_v1_primitives.I_PAIR
                                              []
                                              []
                                          ]
                                      ]
                                      [];
                                    Micheline.Prim
                                      0
                                      Michelson_v1_primitives.I_PAIR
                                      []
                                      []
                                  ]
                              ]
                              []
                          ]
                      ] code_annot
                  ] in
              let migrated_storage :=
                Micheline.Prim 0 Michelson_v1_primitives.D_Pair
                  [
                    Micheline.Bytes 0
                      (Data_encoding.Binary.to_bytes_exn
                        (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding)
                        manager_pkh);
                    storage_expr
                  ] [] in
              ((Pervasives.op_atat Script_repr.__lazy_expr_value
                (Micheline.strip_locations migrated_code)),
                (Pervasives.op_atat Script_repr.__lazy_expr_value
                  (Micheline.strip_locations migrated_storage)))
            | _ => (script_code, script_storage)
            end
          | _ => (script_code, script_storage)
          end)).

Definition has_default_entrypoint (expr : Script_repr.lazy_expr) : bool :=
  match Script_repr.force_decode expr with
  | Pervasives.Error _ => false
  | Pervasives.Ok (expr, _) =>
    match Micheline.root expr with
    | Micheline.Seq _ toplevel =>
      match find_toplevel Michelson_v1_primitives.K_parameter toplevel with
      |
        Some
          (Micheline.Prim _ Michelson_v1_primitives.K_parameter (cons _ [])
            (cons "%default" [])) => false
      |
        Some
          (Micheline.Prim _ Michelson_v1_primitives.K_parameter
            (cons parameter_expr []) _) =>
        let fix has_default {A : Set}
          (function_parameter : Micheline.node A Michelson_v1_primitives.prim)
          {struct function_parameter} : bool :=
          match function_parameter with
          |
            Micheline.Prim _ Michelson_v1_primitives.T_or (cons l (cons r []))
              annots =>
            Pervasives.op_pipepipe
              (List.__exists (String.equal "%default") annots)
              (Pervasives.op_pipepipe (has_default l) (has_default r))
          | Micheline.Prim _ _ _ annots =>
            List.__exists (String.equal "%default") annots
          | _ => false
          end in
        has_default parameter_expr
      | Some _ | None => false
      end
    | _ => false
    end
  end.

Definition add_root_entrypoint (script_code : Script_repr.lazy_expr)
  : Lwt.t (Error_monad.tzresult Script_repr.lazy_expr) :=
  Error_monad.op_gtgtpipequestion
    (Lwt.__return (Script_repr.force_decode script_code))
    (fun function_parameter =>
      let '(script_code_expr, _gas_cost) := function_parameter in
      match Micheline.root script_code_expr with
      | Micheline.Seq _ toplevel =>
        let migrated_code :=
          Micheline.Seq 0
            (List.map
              (fun function_parameter =>
                match function_parameter with
                |
                  Micheline.Prim _ Michelson_v1_primitives.K_parameter
                    (cons parameter_expr []) _ =>
                  Micheline.Prim 0 Michelson_v1_primitives.K_parameter
                    [ parameter_expr ] [ "%root" ]
                | Micheline.Prim _ Michelson_v1_primitives.K_code exprs annots
                  =>
                  let fix rewrite_self
                    (function_parameter :
                      Micheline.node Z Michelson_v1_primitives.prim)
                    {struct function_parameter}
                    : Micheline.node Z Michelson_v1_primitives.prim :=
                    match function_parameter with
                    |
                      (Micheline.Int _ _ | Micheline.String _ _ |
                      Micheline.Bytes _ _ |
                      Micheline.Prim _ Michelson_v1_primitives.I_CREATE_CONTRACT
                        _ _) as leaf => leaf
                    | Micheline.Prim _ Michelson_v1_primitives.I_SELF [] annots
                      =>
                      Micheline.Prim 0 Michelson_v1_primitives.I_SELF []
                        (cons "%root" annots)
                    | Micheline.Prim _ name args annots =>
                      Micheline.Prim 0 name (List.map rewrite_self args) annots
                    | Micheline.Seq _ args =>
                      Micheline.Seq 0 (List.map rewrite_self args)
                    end in
                  Micheline.Prim 0 Michelson_v1_primitives.K_code
                    (List.map rewrite_self exprs) annots
                | other => other
                end) toplevel) in
        Pervasives.op_atat Script_repr.__lazy_expr_value
          (Micheline.strip_locations migrated_code)
      | _ => script_code
      end).

Legacy_script_support_repr_mli

  • OCaml size: 67 lines
  • Coq size: 30 lines (-56% compared to OCaml)
legacy_script_support_repr.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(* Copyright (c) 2019 Cryptium Labs <contact@cryptium-labs.com>              *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This code mimics the now defunct scriptless KT1s.

    The manager contract is from:
    https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/manager.tz
    The formal proof is at:
    https://gitlab.com/nomadic-labs/mi-cho-coq/blob/a7603e12021166e15890f6d504feebec2f945502/src/contracts_coq/manager.v *)
val manager_script_code : Script_repr.lazy_expr

(** This code mimics the now defunct "spendable" flags of KT1s by
    adding a [do] entrypoint, preserving the original script's at
    'default' entrypoint.

    The pseudo-code for the applied transformations is from:
    https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/transform/add_do.tz *)
val add_do :
  manager_pkh:Signature.Public_key_hash.t ->
  script_code:Script_repr.lazy_expr ->
  script_storage:Script_repr.lazy_expr ->
  (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t

(** This code mimics the now defunct "spendable" flags of KT1s by
    adding a [do] entrypoint, preserving the original script's at
    'default' entrypoint.

    The pseudo-code for the applied transformations is from:
    https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/transform/add_set_delegate.tz *)
val add_set_delegate :
  manager_pkh:Signature.Public_key_hash.t ->
  script_code:Script_repr.lazy_expr ->
  script_storage:Script_repr.lazy_expr ->
  (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t

(** Checks if a contract was declaring a default entrypoint somewhere
   else than at the root, in which case its type changes when
   entrypoints are activated. *)
val has_default_entrypoint : Script_repr.lazy_expr -> bool

(** Adds a [%root] annotation on the toplevel parameter construct. *)
val add_root_entrypoint :
  script_code:Script_repr.lazy_expr -> Script_repr.lazy_expr tzresult Lwt.t
Legacy_script_support_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Script_repr.

Parameter manager_script_code : Script_repr.lazy_expr.

Parameter add_do :
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Script_repr.lazy_expr -> Script_repr.lazy_expr ->
  Lwt.t (Error_monad.tzresult (Script_repr.lazy_expr * Script_repr.lazy_expr)).

Parameter add_set_delegate :
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Script_repr.lazy_expr -> Script_repr.lazy_expr ->
  Lwt.t (Error_monad.tzresult (Script_repr.lazy_expr * Script_repr.lazy_expr)).

Parameter has_default_entrypoint : Script_repr.lazy_expr -> bool.

Parameter add_root_entrypoint :
  Script_repr.lazy_expr -> Lwt.t (Error_monad.tzresult Script_repr.lazy_expr).

Level_repr

  • OCaml size: 187 lines
  • Coq size: 211 lines (+12% compared to OCaml)
level_repr.ml success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  level : Raw_level_repr.t;
  level_position : int32;
  cycle : Cycle_repr.t;
  cycle_position : int32;
  voting_period : Voting_period_repr.t;
  voting_period_position : int32;
  expected_commitment : bool;
}

module CompareModule = Compare.Make (struct
  type nonrec t = t

  let compare {level = l1} {level = l2} = Raw_level_repr.compare l1 l2
end)

include CompareModule

type level = t

let pp ppf {level} = Raw_level_repr.pp ppf level

let pp_full ppf l =
  Format.fprintf
    ppf
    "%a.%ld (cycle %a.%ld) (vote %a.%ld)"
    Raw_level_repr.pp
    l.level
    l.level_position
    Cycle_repr.pp
    l.cycle
    l.cycle_position
    Voting_period_repr.pp
    l.voting_period
    l.voting_period_position

let encoding =
  let open Data_encoding in
  conv
    (fun { level;
           level_position;
           cycle;
           cycle_position;
           voting_period;
           voting_period_position;
           expected_commitment } ->
      ( level,
        level_position,
        cycle,
        cycle_position,
        voting_period,
        voting_period_position,
        expected_commitment ))
    (fun ( level,
           level_position,
           cycle,
           cycle_position,
           voting_period,
           voting_period_position,
           expected_commitment ) ->
      {
        level;
        level_position;
        cycle;
        cycle_position;
        voting_period;
        voting_period_position;
        expected_commitment;
      })
    (obj7
       (req
          "level"
          ~description:
            "The level of the block relative to genesis. This is also the \
             Shell's notion of level"
          Raw_level_repr.encoding)
       (req
          "level_position"
          ~description:
            "The level of the block relative to the block that starts \
             protocol alpha. This is specific to the protocol alpha. Other \
             protocols might or might not include a similar notion."
          int32)
       (req
          "cycle"
          ~description:
            "The current cycle's number. Note that cycles are a \
             protocol-specific notion. As a result, the cycle number starts \
             at 0 with the first block of protocol alpha."
          Cycle_repr.encoding)
       (req
          "cycle_position"
          ~description:
            "The current level of the block relative to the first block of \
             the current cycle."
          int32)
       (req
          "voting_period"
          ~description:
            "The current voting period's index. Note that cycles are a \
             protocol-specific notion. As a result, the voting period index \
             starts at 0 with the first block of protocol alpha."
          Voting_period_repr.encoding)
       (req
          "voting_period_position"
          ~description:
            "The current level of the block relative to the first block of \
             the current voting period."
          int32)
       (req
          "expected_commitment"
          ~description:
            "Tells wether the baker of this block has to commit a seed nonce \
             hash."
          bool))

let root first_level =
  {
    level = first_level;
    level_position = 0l;
    cycle = Cycle_repr.root;
    cycle_position = 0l;
    voting_period = Voting_period_repr.root;
    voting_period_position = 0l;
    expected_commitment = false;
  }

let from_raw ~first_level ~blocks_per_cycle ~blocks_per_voting_period
    ~blocks_per_commitment level =
  let raw_level = Raw_level_repr.to_int32 level in
  let first_level = Raw_level_repr.to_int32 first_level in
  let level_position =
    Compare.Int32.max 0l (Int32.sub raw_level first_level)
  in
  let cycle =
    Cycle_repr.of_int32_exn (Int32.div level_position blocks_per_cycle)
  in
  let cycle_position = Int32.rem level_position blocks_per_cycle in
  let voting_period =
    Voting_period_repr.of_int32_exn
      (Int32.div level_position blocks_per_voting_period)
  in
  let voting_period_position =
    Int32.rem level_position blocks_per_voting_period
  in
  let expected_commitment =
    Compare.Int32.(
      Int32.rem cycle_position blocks_per_commitment
      = Int32.pred blocks_per_commitment)
  in
  {
    level;
    level_position;
    cycle;
    cycle_position;
    voting_period;
    voting_period_position;
    expected_commitment;
  }

let diff {level = l1; _} {level = l2; _} =
  Int32.sub (Raw_level_repr.to_int32 l1) (Raw_level_repr.to_int32 l2)
Level_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Cycle_repr.
Require Tezos.Raw_level_repr.
Require Tezos.Voting_period_repr.

Module t.
  Record record := Build {
    level : Raw_level_repr.t;
    level_position : int32;
    cycle : Cycle_repr.t;
    cycle_position : int32;
    voting_period : Voting_period_repr.t;
    voting_period_position : int32;
    expected_commitment : bool }.
  Definition with_level level (r : record) :=
    Build level r.(level_position) r.(cycle) r.(cycle_position)
      r.(voting_period) r.(voting_period_position) r.(expected_commitment).
  Definition with_level_position level_position (r : record) :=
    Build r.(level) level_position r.(cycle) r.(cycle_position)
      r.(voting_period) r.(voting_period_position) r.(expected_commitment).
  Definition with_cycle cycle (r : record) :=
    Build r.(level) r.(level_position) cycle r.(cycle_position)
      r.(voting_period) r.(voting_period_position) r.(expected_commitment).
  Definition with_cycle_position cycle_position (r : record) :=
    Build r.(level) r.(level_position) r.(cycle) cycle_position
      r.(voting_period) r.(voting_period_position) r.(expected_commitment).
  Definition with_voting_period voting_period (r : record) :=
    Build r.(level) r.(level_position) r.(cycle) r.(cycle_position)
      voting_period r.(voting_period_position) r.(expected_commitment).
  Definition with_voting_period_position voting_period_position (r : record) :=
    Build r.(level) r.(level_position) r.(cycle) r.(cycle_position)
      r.(voting_period) voting_period_position r.(expected_commitment).
  Definition with_expected_commitment expected_commitment (r : record) :=
    Build r.(level) r.(level_position) r.(cycle) r.(cycle_position)
      r.(voting_period) r.(voting_period_position) expected_commitment.
End t.
Definition t := t.record.

Definition CompareModule :=
  Compare.Make
    (let t := t in
    let compare (function_parameter : t) : t -> Z :=
      let '{| t.level := l1 |} := function_parameter in
      fun function_parameter =>
        let '{| t.level := l2 |} := function_parameter in
        Raw_level_repr.compare l1 l2 in
    existT _ _
      {|
        Compare.COMPARABLE.compare := compare
      |}).

Definition op_eq := (|CompareModule|).(Compare.S.op_eq).

Definition op_ltgt := (|CompareModule|).(Compare.S.op_ltgt).

Definition op_lt := (|CompareModule|).(Compare.S.op_lt).

Definition op_lteq := (|CompareModule|).(Compare.S.op_lteq).

Definition op_gteq := (|CompareModule|).(Compare.S.op_gteq).

Definition op_gt := (|CompareModule|).(Compare.S.op_gt).

Definition compare := (|CompareModule|).(Compare.S.compare).

Definition equal := (|CompareModule|).(Compare.S.equal).

Definition max := (|CompareModule|).(Compare.S.max).

Definition min := (|CompareModule|).(Compare.S.min).

Definition level := t.

Definition pp (ppf : Format.formatter) (function_parameter : t) : unit :=
  let '{| t.level := level |} := function_parameter in
  Raw_level_repr.pp ppf level.

Definition pp_full (ppf : Format.formatter) (l : t) : unit :=
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Alpha
        (CamlinternalFormatBasics.Char_literal "." % char
          (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " (cycle "
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal "." % char
                  (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal ") (vote "
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal "." % char
                          (CamlinternalFormatBasics.Int32
                            CamlinternalFormatBasics.Int_d
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.No_precision
                            (CamlinternalFormatBasics.Char_literal ")" % char
                              CamlinternalFormatBasics.End_of_format))))))))))))
      "%a.%ld (cycle %a.%ld) (vote %a.%ld)") Raw_level_repr.pp (t.level l)
    (t.level_position l) Cycle_repr.pp (t.cycle l) (t.cycle_position l)
    Voting_period_repr.pp (t.voting_period l) (t.voting_period_position l).

Definition encoding : Data_encoding.encoding t :=
  Data_encoding.conv
    (fun function_parameter =>
      let '{|
        t.level := level;
          t.level_position := level_position;
          t.cycle := cycle;
          t.cycle_position := cycle_position;
          t.voting_period := voting_period;
          t.voting_period_position := voting_period_position;
          t.expected_commitment := expected_commitment
          |} := function_parameter in
      (level, level_position, cycle, cycle_position, voting_period,
        voting_period_position, expected_commitment))
    (fun function_parameter =>
      let
        '(level, level_position, cycle, cycle_position, voting_period,
          voting_period_position, expected_commitment) := function_parameter in
      {| t.level := level; t.level_position := level_position; t.cycle := cycle;
        t.cycle_position := cycle_position; t.voting_period := voting_period;
        t.voting_period_position := voting_period_position;
        t.expected_commitment := expected_commitment |}) None
    (Data_encoding.obj7
      (Data_encoding.req None
        (Some
          "The level of the block relative to genesis. This is also the Shell's notion of level")
        "level" Raw_level_repr.encoding)
      (Data_encoding.req None
        (Some
          "The level of the block relative to the block that starts protocol alpha. This is specific to the protocol alpha. Other protocols might or might not include a similar notion.")
        "level_position" Data_encoding.__int32_value)
      (Data_encoding.req None
        (Some
          "The current cycle's number. Note that cycles are a protocol-specific notion. As a result, the cycle number starts at 0 with the first block of protocol alpha.")
        "cycle" Cycle_repr.encoding)
      (Data_encoding.req None
        (Some
          "The current level of the block relative to the first block of the current cycle.")
        "cycle_position" Data_encoding.__int32_value)
      (Data_encoding.req None
        (Some
          "The current voting period's index. Note that cycles are a protocol-specific notion. As a result, the voting period index starts at 0 with the first block of protocol alpha.")
        "voting_period" Voting_period_repr.encoding)
      (Data_encoding.req None
        (Some
          "The current level of the block relative to the first block of the current voting period.")
        "voting_period_position" Data_encoding.__int32_value)
      (Data_encoding.req None
        (Some
          "Tells wether the baker of this block has to commit a seed nonce hash.")
        "expected_commitment" Data_encoding.__bool_value)).

Definition root (first_level : Raw_level_repr.t) : t :=
  {| t.level := first_level;
    t.level_position :=
      (* ❌ Constant of type int32 is converted to int *)
      0; t.cycle := Cycle_repr.root;
    t.cycle_position :=
      (* ❌ Constant of type int32 is converted to int *)
      0; t.voting_period := Voting_period_repr.root;
    t.voting_period_position :=
      (* ❌ Constant of type int32 is converted to int *)
      0; t.expected_commitment := false |}.

Definition from_raw
  (first_level : Raw_level_repr.raw_level) (blocks_per_cycle : int32)
  (blocks_per_voting_period : int32) (blocks_per_commitment : int32)
  (level : Raw_level_repr.raw_level) : t :=
  let raw_level := Raw_level_repr.to_int32 level in
  let first_level := Raw_level_repr.to_int32 first_level in
  let level_position :=
    (|Compare.Int32|).(Compare.S.max)
      (* ❌ Constant of type int32 is converted to int *)
      0 (Int32.sub raw_level first_level) in
  let cycle :=
    Cycle_repr.of_int32_exn (Int32.div level_position blocks_per_cycle) in
  let cycle_position := Int32.rem level_position blocks_per_cycle in
  let voting_period :=
    Voting_period_repr.of_int32_exn
      (Int32.div level_position blocks_per_voting_period) in
  let voting_period_position :=
    Int32.rem level_position blocks_per_voting_period in
  let expected_commitment :=
    (|Compare.Int32|).(Compare.S.op_eq)
      (Int32.rem cycle_position blocks_per_commitment)
      (Int32.pred blocks_per_commitment) in
  {| t.level := level; t.level_position := level_position; t.cycle := cycle;
    t.cycle_position := cycle_position; t.voting_period := voting_period;
    t.voting_period_position := voting_period_position;
    t.expected_commitment := expected_commitment |}.

Definition diff (function_parameter : t) : t -> int32 :=
  let '{| t.level := l1 |} := function_parameter in
  fun function_parameter =>
    let '{| t.level := l2 |} := function_parameter in
    Int32.sub (Raw_level_repr.to_int32 l1) (Raw_level_repr.to_int32 l2).

Level_repr_mli

  • OCaml size: 74 lines
  • Coq size: 85 lines (+14% compared to OCaml)
level_repr.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = private {
  level : Raw_level_repr.t;
      (** The level of the block relative to genesis. This
                              is also the Shell's notion of level. *)
  level_position : int32;
      (** The level of the block relative to the block that
                            starts protocol alpha. This is specific to the
                            protocol alpha. Other protocols might or might not
                            include a similar notion. *)
  cycle : Cycle_repr.t;
      (** The current cycle's number. Note that cycles are a
                          protocol-specific notion. As a result, the cycle
                          number starts at 0 with the first block of protocol
                          alpha. *)
  cycle_position : int32;
      (** The current level of the block relative to the first
                            block of the current cycle. *)
  voting_period : Voting_period_repr.t;
  voting_period_position : int32;
  expected_commitment : bool;
}

(* Note that, the type `t` above must respect some invariants (hence the
   `private` annotation). Notably:

   level_position = cycle * blocks_per_cycle + cycle_position
*)

type level = t

include Compare.S with type t := level

val encoding : level Data_encoding.t

val pp : Format.formatter -> level -> unit

val pp_full : Format.formatter -> level -> unit

val root : Raw_level_repr.t -> level

val from_raw :
  first_level:Raw_level_repr.t ->
  blocks_per_cycle:int32 ->
  blocks_per_voting_period:int32 ->
  blocks_per_commitment:int32 ->
  Raw_level_repr.t ->
  level

val diff : level -> level -> int32
Level_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Cycle_repr.
Require Tezos.Raw_level_repr.
Require Tezos.Voting_period_repr.

Module t.
  Record record := Build {
    level : Raw_level_repr.t;
    level_position : int32;
    cycle : Cycle_repr.t;
    cycle_position : int32;
    voting_period : Voting_period_repr.t;
    voting_period_position : int32;
    expected_commitment : bool }.
  Definition with_level level (r : record) :=
    Build level r.(level_position) r.(cycle) r.(cycle_position)
      r.(voting_period) r.(voting_period_position) r.(expected_commitment).
  Definition with_level_position level_position (r : record) :=
    Build r.(level) level_position r.(cycle) r.(cycle_position)
      r.(voting_period) r.(voting_period_position) r.(expected_commitment).
  Definition with_cycle cycle (r : record) :=
    Build r.(level) r.(level_position) cycle r.(cycle_position)
      r.(voting_period) r.(voting_period_position) r.(expected_commitment).
  Definition with_cycle_position cycle_position (r : record) :=
    Build r.(level) r.(level_position) r.(cycle) cycle_position
      r.(voting_period) r.(voting_period_position) r.(expected_commitment).
  Definition with_voting_period voting_period (r : record) :=
    Build r.(level) r.(level_position) r.(cycle) r.(cycle_position)
      voting_period r.(voting_period_position) r.(expected_commitment).
  Definition with_voting_period_position voting_period_position (r : record) :=
    Build r.(level) r.(level_position) r.(cycle) r.(cycle_position)
      r.(voting_period) voting_period_position r.(expected_commitment).
  Definition with_expected_commitment expected_commitment (r : record) :=
    Build r.(level) r.(level_position) r.(cycle) r.(cycle_position)
      r.(voting_period) r.(voting_period_position) expected_commitment.
End t.
Definition t := t.record.

Definition level := t.

Parameter Included_S : {_ : unit & Compare.S.signature level}.

Definition op_eq := (|Included_S|).(Compare.S.op_eq).

Definition op_ltgt := (|Included_S|).(Compare.S.op_ltgt).

Definition op_lt := (|Included_S|).(Compare.S.op_lt).

Definition op_lteq := (|Included_S|).(Compare.S.op_lteq).

Definition op_gteq := (|Included_S|).(Compare.S.op_gteq).

Definition op_gt := (|Included_S|).(Compare.S.op_gt).

Definition compare := (|Included_S|).(Compare.S.compare).

Definition equal := (|Included_S|).(Compare.S.equal).

Definition max := (|Included_S|).(Compare.S.max).

Definition min := (|Included_S|).(Compare.S.min).

Parameter encoding : Data_encoding.t level.

Parameter pp : Format.formatter -> level -> unit.

Parameter pp_full : Format.formatter -> level -> unit.

Parameter root : Raw_level_repr.t -> level.

Parameter from_raw :
  Raw_level_repr.t -> int32 -> int32 -> int32 -> Raw_level_repr.t -> level.

Parameter diff : level -> level -> int32.

Level_storage

  • OCaml size: 118 lines
  • Coq size: 139 lines (+17% compared to OCaml)
level_storage.ml 2 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Level_repr

let from_raw c ?offset l =
  let l =
    match offset with
    | None ->
        l
    | Some o ->
        Raw_level_repr.(of_int32_exn (Int32.add (to_int32 l) o))
  in
  let constants = Raw_context.constants c in
  let first_level = Raw_context.first_level c in
  Level_repr.from_raw
    ~first_level
    ~blocks_per_cycle:constants.Constants_repr.blocks_per_cycle
    ~blocks_per_voting_period:constants.Constants_repr.blocks_per_voting_period
    ~blocks_per_commitment:constants.Constants_repr.blocks_per_commitment
    l

let root c = Level_repr.root (Raw_context.first_level c)

let succ c l = from_raw c (Raw_level_repr.succ l.level)

let pred c l =
  match Raw_level_repr.pred l.Level_repr.level with
  | None ->
      None
  | Some l ->
      Some (from_raw c l)

let current ctxt = Raw_context.current_level ctxt

let previous ctxt =
  let l = current ctxt in
  match pred ctxt l with
  | None ->
      assert false (* We never validate the Genesis... *)
  | Some p ->
      p

let first_level_in_cycle ctxt c =
  let constants = Raw_context.constants ctxt in
  let first_level = Raw_context.first_level ctxt in
  from_raw
    ctxt
    (Raw_level_repr.of_int32_exn
       (Int32.add
          (Raw_level_repr.to_int32 first_level)
          (Int32.mul
             constants.Constants_repr.blocks_per_cycle
             (Cycle_repr.to_int32 c))))

let last_level_in_cycle ctxt c =
  match pred ctxt (first_level_in_cycle ctxt (Cycle_repr.succ c)) with
  | None ->
      assert false
  | Some x ->
      x

let levels_in_cycle ctxt cycle =
  let first = first_level_in_cycle ctxt cycle in
  let rec loop n acc =
    if Cycle_repr.(n.cycle = first.cycle) then loop (succ ctxt n) (n :: acc)
    else acc
  in
  loop first []

let levels_in_current_cycle ctxt ?(offset = 0l) () =
  let current_cycle = Cycle_repr.to_int32 (current ctxt).cycle in
  let cycle = Int32.add current_cycle offset in
  if Compare.Int32.(cycle < 0l) then []
  else
    let cycle = Cycle_repr.of_int32_exn cycle in
    levels_in_cycle ctxt cycle

let levels_with_commitments_in_cycle ctxt c =
  let first = first_level_in_cycle ctxt c in
  let rec loop n acc =
    if Cycle_repr.(n.cycle = first.cycle) then
      if n.expected_commitment then loop (succ ctxt n) (n :: acc)
      else loop (succ ctxt n) acc
    else acc
  in
  loop first []

let last_allowed_fork_level c =
  let level = Raw_context.current_level c in
  let preserved_cycles = Constants_storage.preserved_cycles c in
  match Cycle_repr.sub level.cycle preserved_cycles with
  | None ->
      Raw_level_repr.root
  | Some cycle ->
      (first_level_in_cycle c cycle).level
Level_storage.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Constants_repr.
Require Tezos.Constants_storage.
Require Tezos.Cycle_repr.
Require Tezos.Level_repr.
Require Tezos.Raw_context.
Require Tezos.Raw_level_repr.

Import Level_repr.

Definition from_raw
  (c : Raw_context.context) (offset : option int32)
  (l : Raw_level_repr.raw_level) : Level_repr.level :=
  let l :=
    match offset with
    | None => l
    | Some o =>
      Raw_level_repr.of_int32_exn (Int32.add (Raw_level_repr.to_int32 l) o)
    end in
  let constants := Raw_context.constants c in
  let first_level := Raw_context.first_level c in
  Level_repr.from_raw first_level
    (Constants_repr.parametric.blocks_per_cycle constants)
    (Constants_repr.parametric.blocks_per_voting_period constants)
    (Constants_repr.parametric.blocks_per_commitment constants) l.

Definition root (c : Raw_context.context) : Level_repr.level :=
  Level_repr.root (Raw_context.first_level c).

Definition succ (c : Raw_context.context) (l : Level_repr.t)
  : Level_repr.level :=
  from_raw c None (Raw_level_repr.succ (Level_repr.t.level l)).

Definition pred (c : Raw_context.context) (l : Level_repr.t)
  : option Level_repr.level :=
  match Raw_level_repr.pred (Level_repr.t.level l) with
  | None => None
  | Some l => Some (from_raw c None l)
  end.

Definition current (ctxt : Raw_context.context) : Level_repr.t :=
  Raw_context.current_level ctxt.

Definition previous (ctxt : Raw_context.context) : Level_repr.level :=
  let l := current ctxt in
  match pred ctxt l with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some p => p
  end.

Definition first_level_in_cycle
  (ctxt : Raw_context.context) (c : Cycle_repr.cycle) : Level_repr.level :=
  let constants := Raw_context.constants ctxt in
  let first_level := Raw_context.first_level ctxt in
  from_raw ctxt None
    (Raw_level_repr.of_int32_exn
      (Int32.add (Raw_level_repr.to_int32 first_level)
        (Int32.mul (Constants_repr.parametric.blocks_per_cycle constants)
          (Cycle_repr.to_int32 c)))).

Definition last_level_in_cycle
  (ctxt : Raw_context.context) (c : Cycle_repr.cycle) : Level_repr.level :=
  match pred ctxt (first_level_in_cycle ctxt (Cycle_repr.succ c)) with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some x => x
  end.

Definition levels_in_cycle
  (ctxt : Raw_context.context) (cycle : Cycle_repr.cycle) : list Level_repr.t :=
  let first := first_level_in_cycle ctxt cycle in
  let fix loop (n : Level_repr.t) (acc : list Level_repr.t) {struct n}
    : list Level_repr.t :=
    if Cycle_repr.op_eq (Level_repr.t.cycle n) (Level_repr.t.cycle first) then
      loop (succ ctxt n) (cons n acc)
    else
      acc in
  loop first [].

Definition levels_in_current_cycle
  (ctxt : Raw_context.context) (op_staroptstar : option int32)
  : unit -> list Level_repr.t :=
  let offset :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Constant of type int32 is converted to int *)
      0
    end in
  fun function_parameter =>
    let '_ := function_parameter in
    let current_cycle := Cycle_repr.to_int32 (Level_repr.t.cycle (current ctxt))
      in
    let cycle := Int32.add current_cycle offset in
    if
      (|Compare.Int32|).(Compare.S.op_lt) cycle
        (* ❌ Constant of type int32 is converted to int *)
        0 then
      []
    else
      let cycle := Cycle_repr.of_int32_exn cycle in
      levels_in_cycle ctxt cycle.

Definition levels_with_commitments_in_cycle
  (ctxt : Raw_context.context) (c : Cycle_repr.cycle) : list Level_repr.t :=
  let first := first_level_in_cycle ctxt c in
  let fix loop (n : Level_repr.t) (acc : list Level_repr.t) {struct n}
    : list Level_repr.t :=
    if Cycle_repr.op_eq (Level_repr.t.cycle n) (Level_repr.t.cycle first) then
      if Level_repr.t.expected_commitment n then
        loop (succ ctxt n) (cons n acc)
      else
        loop (succ ctxt n) acc
    else
      acc in
  loop first [].

Definition last_allowed_fork_level (c : Raw_context.context)
  : Raw_level_repr.raw_level :=
  let level := Raw_context.current_level c in
  let preserved_cycles := Constants_storage.preserved_cycles c in
  match Cycle_repr.sub (Level_repr.t.cycle level) preserved_cycles with
  | None => Raw_level_repr.root
  | Some cycle => Level_repr.t.level (first_level_in_cycle c cycle)
  end.

Level_storage_mli

  • OCaml size: 51 lines
  • Coq size: 43 lines (-16% compared to OCaml)
level_storage.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val current : Raw_context.t -> Level_repr.t

val previous : Raw_context.t -> Level_repr.t

val root : Raw_context.t -> Level_repr.t

val from_raw :
  Raw_context.t -> ?offset:int32 -> Raw_level_repr.t -> Level_repr.t

val pred : Raw_context.t -> Level_repr.t -> Level_repr.t option

val succ : Raw_context.t -> Level_repr.t -> Level_repr.t

val first_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t

val last_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t

val levels_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t list

val levels_in_current_cycle :
  Raw_context.t -> ?offset:int32 -> unit -> Level_repr.t list

val levels_with_commitments_in_cycle :
  Raw_context.t -> Cycle_repr.t -> Level_repr.t list

val last_allowed_fork_level : Raw_context.t -> Raw_level_repr.t
Level_storage_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Cycle_repr.
Require Tezos.Level_repr.
Require Tezos.Raw_context.
Require Tezos.Raw_level_repr.

Parameter current : Raw_context.t -> Level_repr.t.

Parameter previous : Raw_context.t -> Level_repr.t.

Parameter root : Raw_context.t -> Level_repr.t.

Parameter from_raw :
  Raw_context.t -> option int32 -> Raw_level_repr.t -> Level_repr.t.

Parameter pred : Raw_context.t -> Level_repr.t -> option Level_repr.t.

Parameter succ : Raw_context.t -> Level_repr.t -> Level_repr.t.

Parameter first_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t.

Parameter last_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t.

Parameter levels_in_cycle : Raw_context.t -> Cycle_repr.t -> list Level_repr.t.

Parameter levels_in_current_cycle :
  Raw_context.t -> option int32 -> unit -> list Level_repr.t.

Parameter levels_with_commitments_in_cycle :
  Raw_context.t -> Cycle_repr.t -> list Level_repr.t.

Parameter last_allowed_fork_level : Raw_context.t -> Raw_level_repr.t.

Main

  • OCaml size: 380 lines
  • Coq size: 629 lines (+65% compared to OCaml)
main.ml 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Protocol Signature Instance *)

type block_header_data = Alpha_context.Block_header.protocol_data

type block_header = Alpha_context.Block_header.t = {
  shell : Block_header.shell_header;
  protocol_data : block_header_data;
}

let block_header_data_encoding =
  Alpha_context.Block_header.protocol_data_encoding

type block_header_metadata = Apply_results.block_metadata

let block_header_metadata_encoding = Apply_results.block_metadata_encoding

type operation_data = Alpha_context.packed_protocol_data =
  | Operation_data :
      'kind Alpha_context.Operation.protocol_data
      -> operation_data

let operation_data_encoding = Alpha_context.Operation.protocol_data_encoding

type operation_receipt = Apply_results.packed_operation_metadata =
  | Operation_metadata :
      'kind Apply_results.operation_metadata
      -> operation_receipt
  | No_operation_metadata : operation_receipt

let operation_receipt_encoding = Apply_results.operation_metadata_encoding

let operation_data_and_receipt_encoding =
  Apply_results.operation_data_and_metadata_encoding

type operation = Alpha_context.packed_operation = {
  shell : Operation.shell_header;
  protocol_data : operation_data;
}

let acceptable_passes = Alpha_context.Operation.acceptable_passes

let max_block_length = Alpha_context.Block_header.max_header_length

let max_operation_data_length =
  Alpha_context.Constants.max_operation_data_length

let validation_passes =
  let max_anonymous_operations =
    Alpha_context.Constants.max_revelations_per_block
    + (* allow 100 wallet activations or denunciations per block *) 100
  in
  Updater.
    [ {max_size = 32 * 1024; max_op = Some 32};
      (* 32 endorsements *)
      {max_size = 32 * 1024; max_op = None};
      (* 32k of voting operations *)
      {
        max_size = max_anonymous_operations * 1024;
        max_op = Some max_anonymous_operations;
      };
      {max_size = 512 * 1024; max_op = None} ]

(* 512kB *)

let rpc_services =
  Alpha_services.register () ;
  Services_registration.get_rpc_services ()

type validation_mode =
  | Application of {
      block_header : Alpha_context.Block_header.t;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }
  | Partial_application of {
      block_header : Alpha_context.Block_header.t;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }
  | Partial_construction of {predecessor : Block_hash.t}
  | Full_construction of {
      predecessor : Block_hash.t;
      protocol_data : Alpha_context.Block_header.contents;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }

type validation_state = {
  mode : validation_mode;
  chain_id : Chain_id.t;
  ctxt : Alpha_context.t;
  op_count : int;
}

let current_context {ctxt; _} = return (Alpha_context.finalize ctxt).context

let begin_partial_application ~chain_id ~ancestor_context:ctxt
    ~predecessor_timestamp ~predecessor_fitness
    (block_header : Alpha_context.Block_header.t) =
  let level = block_header.shell.level in
  let fitness = predecessor_fitness in
  let timestamp = block_header.shell.timestamp in
  Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
  >>=? fun ctxt ->
  Apply.begin_application ctxt chain_id block_header predecessor_timestamp
  >>=? fun (ctxt, baker, block_delay) ->
  let mode =
    Partial_application
      {block_header; baker = Signature.Public_key.hash baker; block_delay}
  in
  return {mode; chain_id; ctxt; op_count = 0}

let begin_application ~chain_id ~predecessor_context:ctxt
    ~predecessor_timestamp ~predecessor_fitness
    (block_header : Alpha_context.Block_header.t) =
  let level = block_header.shell.level in
  let fitness = predecessor_fitness in
  let timestamp = block_header.shell.timestamp in
  Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
  >>=? fun ctxt ->
  Apply.begin_application ctxt chain_id block_header predecessor_timestamp
  >>=? fun (ctxt, baker, block_delay) ->
  let mode =
    Application
      {block_header; baker = Signature.Public_key.hash baker; block_delay}
  in
  return {mode; chain_id; ctxt; op_count = 0}

let begin_construction ~chain_id ~predecessor_context:ctxt
    ~predecessor_timestamp ~predecessor_level:pred_level
    ~predecessor_fitness:pred_fitness ~predecessor ~timestamp
    ?(protocol_data : block_header_data option) () =
  let level = Int32.succ pred_level in
  let fitness = pred_fitness in
  Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
  >>=? fun ctxt ->
  ( match protocol_data with
  | None ->
      Apply.begin_partial_construction ctxt
      >>=? fun ctxt ->
      let mode = Partial_construction {predecessor} in
      return (mode, ctxt)
  | Some proto_header ->
      Apply.begin_full_construction
        ctxt
        predecessor_timestamp
        proto_header.contents
      >>=? fun (ctxt, protocol_data, baker, block_delay) ->
      let mode =
        let baker = Signature.Public_key.hash baker in
        Full_construction {predecessor; baker; protocol_data; block_delay}
      in
      return (mode, ctxt) )
  >>=? fun (mode, ctxt) -> return {mode; chain_id; ctxt; op_count = 0}

let apply_operation ({mode; chain_id; ctxt; op_count; _} as data)
    (operation : Alpha_context.packed_operation) =
  match mode with
  | Partial_application _
    when not
           (List.exists
              (Compare.Int.equal 0)
              (Alpha_context.Operation.acceptable_passes operation)) ->
      (* Multipass validation only considers operations in pass 0. *)
      let op_count = op_count + 1 in
      return ({data with ctxt; op_count}, No_operation_metadata)
  | _ ->
      let {shell; protocol_data = Operation_data protocol_data} = operation in
      let operation : _ Alpha_context.operation = {shell; protocol_data} in
      let (predecessor, baker) =
        match mode with
        | Partial_application
            {block_header = {shell = {predecessor; _}; _}; baker}
        | Application {block_header = {shell = {predecessor; _}; _}; baker}
        | Full_construction {predecessor; baker; _} ->
            (predecessor, baker)
        | Partial_construction {predecessor} ->
            (predecessor, Signature.Public_key_hash.zero)
      in
      Apply.apply_operation
        ctxt
        chain_id
        Optimized
        predecessor
        baker
        (Alpha_context.Operation.hash operation)
        operation
      >>=? fun (ctxt, result) ->
      let op_count = op_count + 1 in
      return ({data with ctxt; op_count}, Operation_metadata result)

let finalize_block {mode; ctxt; op_count} =
  match mode with
  | Partial_construction _ ->
      let level = Alpha_context.Level.current ctxt in
      Alpha_context.Vote.get_current_period_kind ctxt
      >>=? fun voting_period_kind ->
      let baker = Signature.Public_key_hash.zero in
      Signature.Public_key_hash.Map.fold
        (fun delegate deposit ctxt ->
          ctxt
          >>=? fun ctxt ->
          Alpha_context.Delegate.freeze_deposit ctxt delegate deposit)
        (Alpha_context.get_deposits ctxt)
        (return ctxt)
      >>=? fun ctxt ->
      let ctxt = Alpha_context.finalize ctxt in
      return
        ( ctxt,
          Apply_results.
            {
              baker;
              level;
              voting_period_kind;
              nonce_hash = None;
              consumed_gas = Z.zero;
              deactivated = [];
              balance_updates = [];
            } )
  | Partial_application {block_header; baker; block_delay} ->
      let level = Alpha_context.Level.current ctxt in
      let included_endorsements = Alpha_context.included_endorsements ctxt in
      Apply.check_minimum_endorsements
        ctxt
        block_header.protocol_data.contents
        block_delay
        included_endorsements
      >>=? fun () ->
      Alpha_context.Vote.get_current_period_kind ctxt
      >>=? fun voting_period_kind ->
      let ctxt = Alpha_context.finalize ctxt in
      return
        ( ctxt,
          Apply_results.
            {
              baker;
              level;
              voting_period_kind;
              nonce_hash = None;
              consumed_gas = Z.zero;
              deactivated = [];
              balance_updates = [];
            } )
  | Application
      { baker;
        block_delay;
        block_header = {protocol_data = {contents = protocol_data; _}; _} }
  | Full_construction {protocol_data; baker; block_delay; _} ->
      Apply.finalize_application ctxt protocol_data baker ~block_delay
      >>=? fun (ctxt, receipt) ->
      let level = Alpha_context.Level.current ctxt in
      let priority = protocol_data.priority in
      let raw_level = Alpha_context.Raw_level.to_int32 level.level in
      let fitness = Alpha_context.Fitness.current ctxt in
      let commit_message =
        Format.asprintf
          "lvl %ld, fit 1:%Ld, prio %d, %d ops"
          raw_level
          fitness
          priority
          op_count
      in
      let ctxt = Alpha_context.finalize ~commit_message ctxt in
      return (ctxt, receipt)

let compare_operations op1 op2 =
  let open Alpha_context in
  let (Operation_data op1) = op1.protocol_data in
  let (Operation_data op2) = op2.protocol_data in
  match (op1.contents, op2.contents) with
  | (Single (Endorsement _), Single (Endorsement _)) ->
      0
  | (_, Single (Endorsement _)) ->
      1
  | (Single (Endorsement _), _) ->
      -1
  | (Single (Seed_nonce_revelation _), Single (Seed_nonce_revelation _)) ->
      0
  | (_, Single (Seed_nonce_revelation _)) ->
      1
  | (Single (Seed_nonce_revelation _), _) ->
      -1
  | ( Single (Double_endorsement_evidence _),
      Single (Double_endorsement_evidence _) ) ->
      0
  | (_, Single (Double_endorsement_evidence _)) ->
      1
  | (Single (Double_endorsement_evidence _), _) ->
      -1
  | (Single (Double_baking_evidence _), Single (Double_baking_evidence _)) ->
      0
  | (_, Single (Double_baking_evidence _)) ->
      1
  | (Single (Double_baking_evidence _), _) ->
      -1
  | (Single (Activate_account _), Single (Activate_account _)) ->
      0
  | (_, Single (Activate_account _)) ->
      1
  | (Single (Activate_account _), _) ->
      -1
  | (Single (Proposals _), Single (Proposals _)) ->
      0
  | (_, Single (Proposals _)) ->
      1
  | (Single (Proposals _), _) ->
      -1
  | (Single (Ballot _), Single (Ballot _)) ->
      0
  | (_, Single (Ballot _)) ->
      1
  | (Single (Ballot _), _) ->
      -1
  (* Manager operations with smaller counter are pre-validated first. *)
  | (Single (Manager_operation op1), Single (Manager_operation op2)) ->
      Z.compare op1.counter op2.counter
  | (Cons (Manager_operation op1, _), Single (Manager_operation op2)) ->
      Z.compare op1.counter op2.counter
  | (Single (Manager_operation op1), Cons (Manager_operation op2, _)) ->
      Z.compare op1.counter op2.counter
  | (Cons (Manager_operation op1, _), Cons (Manager_operation op2, _)) ->
      Z.compare op1.counter op2.counter

let init ctxt block_header =
  let level = block_header.Block_header.level in
  let fitness = block_header.fitness in
  let timestamp = block_header.timestamp in
  let typecheck (ctxt : Alpha_context.context)
      (script : Alpha_context.Script.t) =
    Script_ir_translator.parse_script ctxt ~legacy:false script
    >>=? fun (Ex_script parsed_script, ctxt) ->
    Script_ir_translator.extract_big_map_diff
      ctxt
      Optimized
      parsed_script.storage_type
      parsed_script.storage
      ~to_duplicate:Script_ir_translator.no_big_map_id
      ~to_update:Script_ir_translator.no_big_map_id
      ~temporary:false
    >>=? fun (storage, big_map_diff, ctxt) ->
    Script_ir_translator.unparse_data
      ctxt
      Optimized
      parsed_script.storage_type
      storage
    >>=? fun (storage, ctxt) ->
    let storage =
      Alpha_context.Script.lazy_expr (Micheline.strip_locations storage)
    in
    return (({script with storage}, big_map_diff), ctxt)
  in
  Alpha_context.prepare_first_block ~typecheck ~level ~timestamp ~fitness ctxt
  >>=? fun ctxt -> return (Alpha_context.finalize ctxt)

(* Vanity nonce: 313282890 *)
Main.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Apply.
Require Tezos.Apply_results.
Require Tezos.Script_ir_translator.
Require Tezos.Script_typed_ir.
Require Tezos.Services_registration.

Definition block_header_data := Alpha_context.Block_header.protocol_data.

Module block_header.
  Record record := Build {
    shell : Block_header.shell_header;
    protocol_data : block_header_data }.
  Definition with_shell shell (r : record) :=
    Build shell r.(protocol_data).
  Definition with_protocol_data protocol_data (r : record) :=
    Build r.(shell) protocol_data.
End block_header.
Definition block_header := block_header.record.

Definition block_header_data_encoding
  : Data_encoding.encoding Alpha_context.Block_header.protocol_data :=
  Alpha_context.Block_header.protocol_data_encoding.

Definition block_header_metadata := Apply_results.block_metadata.

Definition block_header_metadata_encoding
  : Data_encoding.encoding Apply_results.block_metadata :=
  Apply_results.block_metadata_encoding.

Reserved Notation "'operation_data".

Inductive operation_data_gadt : Set :=
| Operation_data : forall {kind : Set},
  Alpha_context.Operation.protocol_data kind -> operation_data_gadt

where "'operation_data" := (operation_data_gadt).

Definition operation_data := 'operation_data.

Definition operation_data_encoding
  : Data_encoding.t Alpha_context.Operation.packed_protocol_data :=
  Alpha_context.Operation.protocol_data_encoding.

Reserved Notation "'operation_receipt".

Inductive operation_receipt_gadt : Set :=
| Operation_metadata : forall {kind : Set},
  Apply_results.operation_metadata kind -> operation_receipt_gadt
| No_operation_metadata : operation_receipt_gadt

where "'operation_receipt" := (operation_receipt_gadt).

Definition operation_receipt := 'operation_receipt.

Definition operation_receipt_encoding
  : Data_encoding.t Apply_results.packed_operation_metadata :=
  Apply_results.operation_metadata_encoding.

Definition operation_data_and_receipt_encoding
  : Data_encoding.t
    (Alpha_context.Operation.packed_protocol_data *
      Apply_results.packed_operation_metadata) :=
  Apply_results.operation_data_and_metadata_encoding.

Module operation.
  Record record := Build {
    shell : Operation.shell_header;
    protocol_data : operation_data }.
  Definition with_shell shell (r : record) :=
    Build shell r.(protocol_data).
  Definition with_protocol_data protocol_data (r : record) :=
    Build r.(shell) protocol_data.
End operation.
Definition operation := operation.record.

Definition acceptable_passes : Alpha_context.packed_operation -> list Z :=
  Alpha_context.Operation.acceptable_passes.

Definition max_block_length : Z := Alpha_context.Block_header.max_header_length.

Definition max_operation_data_length : Z :=
  Alpha_context.Constants.max_operation_data_length.

Definition validation_passes : list Updater.quota :=
  let max_anonymous_operations :=
    Pervasives.op_plus Alpha_context.Constants.max_revelations_per_block 100 in
  [
    {| Updater.quota.max_size := Pervasives.op_star 32 1024;
      Updater.quota.max_op := Some 32 |};
    {| Updater.quota.max_size := Pervasives.op_star 32 1024;
      Updater.quota.max_op := None |};
    {|
      Updater.quota.max_size := Pervasives.op_star max_anonymous_operations 1024;
      Updater.quota.max_op := Some max_anonymous_operations |};
    {| Updater.quota.max_size := Pervasives.op_star 512 1024;
      Updater.quota.max_op := None |}
  ].

Definition rpc_services : RPC_directory.directory Updater.rpc_context :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  Services_registration.get_rpc_services tt.

Module validation_mode.
  Module Application.
    Record record {block_header baker block_delay : Set} := {
      block_header : block_header;
      baker : baker;
      block_delay : block_delay }.
    Arguments record : clear implicits.
  End Application.
  Definition Application_skeleton := Application.record.
  
  Module Partial_application.
    Record record {block_header baker block_delay : Set} := {
      block_header : block_header;
      baker : baker;
      block_delay : block_delay }.
    Arguments record : clear implicits.
  End Partial_application.
  Definition Partial_application_skeleton := Partial_application.record.
  
  Module Partial_construction.
    Record record {predecessor : Set} := {
      predecessor : predecessor }.
    Arguments record : clear implicits.
  End Partial_construction.
  Definition Partial_construction_skeleton := Partial_construction.record.
  
  Module Full_construction.
    Record record {predecessor protocol_data baker block_delay : Set} := {
      predecessor : predecessor;
      protocol_data : protocol_data;
      baker : baker;
      block_delay : block_delay }.
    Arguments record : clear implicits.
  End Full_construction.
  Definition Full_construction_skeleton := Full_construction.record.
End validation_mode.

Reserved Notation "'validation_mode.Application".
Reserved Notation "'validation_mode.Partial_application".
Reserved Notation "'validation_mode.Partial_construction".
Reserved Notation "'validation_mode.Full_construction".

Inductive validation_mode : Set :=
| Application : 'validation_mode.Application -> validation_mode
| Partial_application : 'validation_mode.Partial_application -> validation_mode
| Partial_construction :
  'validation_mode.Partial_construction -> validation_mode
| Full_construction : 'validation_mode.Full_construction -> validation_mode

where "'validation_mode.Application" :=
  (validation_mode.Application_skeleton Alpha_context.Block_header.t
    Alpha_context.public_key_hash Alpha_context.Period.t)
and "'validation_mode.Partial_application" :=
  (validation_mode.Partial_application_skeleton Alpha_context.Block_header.t
    Alpha_context.public_key_hash Alpha_context.Period.t)
and "'validation_mode.Partial_construction" :=
  (validation_mode.Partial_construction_skeleton (|Block_hash|).(S.HASH.t))
and "'validation_mode.Full_construction" :=
  (validation_mode.Full_construction_skeleton (|Block_hash|).(S.HASH.t)
    Alpha_context.Block_header.contents Alpha_context.public_key_hash
    Alpha_context.Period.t).

Module ConstructorRecordNotations_validation_mode.
  Module validation_mode.
    Definition Application := 'validation_mode.Application.
    Definition Partial_application := 'validation_mode.Partial_application.
    Definition Partial_construction := 'validation_mode.Partial_construction.
    Definition Full_construction := 'validation_mode.Full_construction.
  End validation_mode.
End ConstructorRecordNotations_validation_mode.
Import ConstructorRecordNotations_validation_mode.

Module validation_state.
  Record record := Build {
    mode : validation_mode;
    chain_id : (|Chain_id|).(S.HASH.t);
    ctxt : Alpha_context.t;
    op_count : Z }.
  Definition with_mode mode (r : record) :=
    Build mode r.(chain_id) r.(ctxt) r.(op_count).
  Definition with_chain_id chain_id (r : record) :=
    Build r.(mode) chain_id r.(ctxt) r.(op_count).
  Definition with_ctxt ctxt (r : record) :=
    Build r.(mode) r.(chain_id) ctxt r.(op_count).
  Definition with_op_count op_count (r : record) :=
    Build r.(mode) r.(chain_id) r.(ctxt) op_count.
End validation_state.
Definition validation_state := validation_state.record.

Definition current_context (function_parameter : validation_state)
  : Lwt.t (Error_monad.tzresult Context.t) :=
  let '{| validation_state.ctxt := ctxt |} := function_parameter in
  Error_monad.__return
    (Updater.validation_result.context (Alpha_context.finalize None ctxt)).

Definition begin_partial_application
  (chain_id : (|Chain_id|).(S.HASH.t)) (ctxt : Context.t)
  (predecessor_timestamp : Time.t)
  (predecessor_fitness : Alpha_context.Fitness.t)
  (block_header : Alpha_context.Block_header.t)
  : Lwt.t (Error_monad.tzresult validation_state) :=
  let level := Block_header.shell_header.level (block_header.shell block_header)
    in
  let fitness := predecessor_fitness in
  let timestamp :=
    Block_header.shell_header.timestamp (block_header.shell block_header) in
  Error_monad.op_gtgteqquestion
    (Alpha_context.prepare ctxt level predecessor_timestamp timestamp fitness)
    (fun ctxt =>
      Error_monad.op_gtgteqquestion
        (Apply.begin_application ctxt chain_id block_header
          predecessor_timestamp)
        (fun function_parameter =>
          let '(ctxt, baker, block_delay) := function_parameter in
          let mode :=
            Partial_application
              {|
                validation_mode.Partial_application.block_header := block_header;
                validation_mode.Partial_application.baker :=
                  (|Signature.Public_key|).(S.SPublic_key.__hash_value) baker;
                validation_mode.Partial_application.block_delay := block_delay
                |} in
          Error_monad.__return
            {| validation_state.mode := mode;
              validation_state.chain_id := chain_id;
              validation_state.ctxt := ctxt; validation_state.op_count := 0 |})).

Definition begin_application
  (chain_id : (|Chain_id|).(S.HASH.t)) (ctxt : Context.t)
  (predecessor_timestamp : Time.t)
  (predecessor_fitness : Alpha_context.Fitness.t)
  (block_header : Alpha_context.Block_header.t)
  : Lwt.t (Error_monad.tzresult validation_state) :=
  let level := Block_header.shell_header.level (block_header.shell block_header)
    in
  let fitness := predecessor_fitness in
  let timestamp :=
    Block_header.shell_header.timestamp (block_header.shell block_header) in
  Error_monad.op_gtgteqquestion
    (Alpha_context.prepare ctxt level predecessor_timestamp timestamp fitness)
    (fun ctxt =>
      Error_monad.op_gtgteqquestion
        (Apply.begin_application ctxt chain_id block_header
          predecessor_timestamp)
        (fun function_parameter =>
          let '(ctxt, baker, block_delay) := function_parameter in
          let mode :=
            Application
              {| validation_mode.Application.block_header := block_header;
                validation_mode.Application.baker :=
                  (|Signature.Public_key|).(S.SPublic_key.__hash_value) baker;
                validation_mode.Application.block_delay := block_delay |} in
          Error_monad.__return
            {| validation_state.mode := mode;
              validation_state.chain_id := chain_id;
              validation_state.ctxt := ctxt; validation_state.op_count := 0 |})).

Definition begin_construction
  (chain_id : (|Chain_id|).(S.HASH.t)) (ctxt : Context.t)
  (predecessor_timestamp : Time.t) (pred_level : int32)
  (pred_fitness : Alpha_context.Fitness.t)
  (predecessor : (|Block_hash|).(S.HASH.t)) (timestamp : Time.t)
  (protocol_data : option block_header_data) (function_parameter : unit)
  : Lwt.t (Error_monad.tzresult validation_state) :=
  let '_ := function_parameter in
  let level := Int32.succ pred_level in
  let fitness := pred_fitness in
  Error_monad.op_gtgteqquestion
    (Alpha_context.prepare ctxt level predecessor_timestamp timestamp fitness)
    (fun ctxt =>
      Error_monad.op_gtgteqquestion
        match protocol_data with
        | None =>
          Error_monad.op_gtgteqquestion (Apply.begin_partial_construction ctxt)
            (fun ctxt =>
              let mode :=
                Partial_construction
                  {|
                    validation_mode.Partial_construction.predecessor :=
                      predecessor |} in
              Error_monad.__return (mode, ctxt))
        | Some proto_header =>
          Error_monad.op_gtgteqquestion
            (Apply.begin_full_construction ctxt predecessor_timestamp
              (Alpha_context.Block_header.protocol_data.contents proto_header))
            (fun function_parameter =>
              let '(ctxt, protocol_data, baker, block_delay) :=
                function_parameter in
              let mode :=
                let baker :=
                  (|Signature.Public_key|).(S.SPublic_key.__hash_value) baker in
                Full_construction
                  {|
                    validation_mode.Full_construction.predecessor := predecessor;
                    validation_mode.Full_construction.protocol_data :=
                      protocol_data;
                    validation_mode.Full_construction.baker := baker;
                    validation_mode.Full_construction.block_delay := block_delay
                    |} in
              Error_monad.__return (mode, ctxt))
        end
        (fun function_parameter =>
          let '(mode, ctxt) := function_parameter in
          Error_monad.__return
            {| validation_state.mode := mode;
              validation_state.chain_id := chain_id;
              validation_state.ctxt := ctxt; validation_state.op_count := 0 |})).

Definition apply_operation (function_parameter : validation_state)
  : Alpha_context.packed_operation ->
  Lwt.t (Error_monad.tzresult (validation_state * operation_receipt)) :=
  let
    '{|
      validation_state.mode := mode;
        validation_state.chain_id := chain_id;
        validation_state.ctxt := ctxt;
        validation_state.op_count := op_count
        |} as data := function_parameter in
  fun operation =>
    match
      (mode,
        match mode with
        | Partial_application _ =>
          Pervasives.not
            (List.__exists ((|Compare.Int|).(Compare.S.equal) 0)
              (Alpha_context.Operation.acceptable_passes operation))
        | _ => false
        end) with
    | (Partial_application _, true) =>
      let op_count := Pervasives.op_plus op_count 1 in
      Error_monad.__return
        ((validation_state.with_op_count op_count
          (validation_state.with_ctxt ctxt data)), No_operation_metadata)
    | (_, _) =>
      let '{|
        operation.shell := shell;
          operation.protocol_data := Operation_data protocol_data
          |} := operation in
      let operation :=
        {| Alpha_context.operation.shell := shell;
          Alpha_context.operation.protocol_data := protocol_data |} in
      let '(predecessor, baker) :=
        match mode with
        |
          Partial_application {|
            validation_mode.Partial_application.block_header := {|
              block_header.shell := {|
                Block_header.shell_header.predecessor := predecessor
                  |}
                |};
              validation_mode.Partial_application.baker := baker
              |} |
          Application {|
            validation_mode.Application.block_header := {|
              block_header.shell := {|
                Block_header.shell_header.predecessor := predecessor
                  |}
                |};
              validation_mode.Application.baker := baker
              |} |
          Full_construction {|
            validation_mode.Full_construction.predecessor := predecessor;
              validation_mode.Full_construction.baker := baker
              |} => (predecessor, baker)
        |
          Partial_construction {|
            validation_mode.Partial_construction.predecessor := predecessor
              |} =>
          (predecessor, (|Signature.Public_key_hash|).(S.SPublic_key_hash.zero))
        end in
      Error_monad.op_gtgteqquestion
        (Apply.apply_operation ctxt chain_id Script_ir_translator.Optimized
          predecessor baker (Alpha_context.Operation.__hash_value operation)
          operation)
        (fun function_parameter =>
          let '(ctxt, __result_value) := function_parameter in
          let op_count := Pervasives.op_plus op_count 1 in
          Error_monad.__return
            ((validation_state.with_op_count op_count
              (validation_state.with_ctxt ctxt data)),
              (Operation_metadata __result_value)))
    end.

Definition finalize_block (function_parameter : validation_state)
  : Lwt.t
    (Error_monad.tzresult
      (Updater.validation_result * Apply_results.block_metadata)) :=
  let '{|
    validation_state.mode := mode;
      validation_state.ctxt := ctxt;
      validation_state.op_count := op_count
      |} := function_parameter in
  match mode with
  | Partial_construction _ =>
    let level := Alpha_context.Level.current ctxt in
    Error_monad.op_gtgteqquestion
      (Alpha_context.Vote.get_current_period_kind ctxt)
      (fun voting_period_kind =>
        let baker := (|Signature.Public_key_hash|).(S.SPublic_key_hash.zero) in
        Error_monad.op_gtgteqquestion
          ((|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.fold)
            (fun delegate =>
              fun deposit =>
                fun ctxt =>
                  Error_monad.op_gtgteqquestion ctxt
                    (fun ctxt =>
                      Alpha_context.Delegate.freeze_deposit ctxt delegate
                        deposit)) (Alpha_context.get_deposits ctxt)
            (Error_monad.__return ctxt))
          (fun ctxt =>
            let ctxt := Alpha_context.finalize None ctxt in
            Error_monad.__return
              (ctxt,
                {| Apply_results.block_metadata.baker := baker;
                  Apply_results.block_metadata.level := level;
                  Apply_results.block_metadata.voting_period_kind :=
                    voting_period_kind;
                  Apply_results.block_metadata.nonce_hash := None;
                  Apply_results.block_metadata.consumed_gas := Z.zero;
                  Apply_results.block_metadata.deactivated := [];
                  Apply_results.block_metadata.balance_updates := [] |})))
  |
    Partial_application {|
      validation_mode.Partial_application.block_header := block_header;
        validation_mode.Partial_application.baker := baker;
        validation_mode.Partial_application.block_delay := block_delay
        |} =>
    let level := Alpha_context.Level.current ctxt in
    let included_endorsements := Alpha_context.included_endorsements ctxt in
    Error_monad.op_gtgteqquestion
      (Apply.check_minimum_endorsements ctxt
        (Alpha_context.Block_header.protocol_data.contents
          (block_header.protocol_data block_header)) block_delay
        included_endorsements)
      (fun function_parameter =>
        let '_ := function_parameter in
        Error_monad.op_gtgteqquestion
          (Alpha_context.Vote.get_current_period_kind ctxt)
          (fun voting_period_kind =>
            let ctxt := Alpha_context.finalize None ctxt in
            Error_monad.__return
              (ctxt,
                {| Apply_results.block_metadata.baker := baker;
                  Apply_results.block_metadata.level := level;
                  Apply_results.block_metadata.voting_period_kind :=
                    voting_period_kind;
                  Apply_results.block_metadata.nonce_hash := None;
                  Apply_results.block_metadata.consumed_gas := Z.zero;
                  Apply_results.block_metadata.deactivated := [];
                  Apply_results.block_metadata.balance_updates := [] |})))
  |
    Application {|
      validation_mode.Application.block_header := {|
        block_header.protocol_data := {|
          Alpha_context.Block_header.protocol_data.contents := protocol_data
            |}
          |};
        validation_mode.Application.baker := baker;
        validation_mode.Application.block_delay := block_delay
        |} |
    Full_construction {|
      validation_mode.Full_construction.protocol_data := protocol_data;
        validation_mode.Full_construction.baker := baker;
        validation_mode.Full_construction.block_delay := block_delay
        |} =>
    Error_monad.op_gtgteqquestion
      (Apply.finalize_application ctxt protocol_data baker block_delay)
      (fun function_parameter =>
        let '(ctxt, receipt) := function_parameter in
        let level := Alpha_context.Level.current ctxt in
        let priority :=
          Alpha_context.Block_header.contents.priority protocol_data in
        let raw_level :=
          Alpha_context.Raw_level.to_int32 (Alpha_context.Level.t.level level)
          in
        let fitness := Alpha_context.Fitness.current ctxt in
        let commit_message :=
          Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "lvl "
                (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.String_literal ", fit 1:"
                    (CamlinternalFormatBasics.Int64
                      CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.String_literal ", prio "
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.String_literal ", "
                            (CamlinternalFormatBasics.Int
                              CamlinternalFormatBasics.Int_d
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.No_precision
                              (CamlinternalFormatBasics.String_literal " ops"
                                CamlinternalFormatBasics.End_of_format)))))))))
              "lvl %ld, fit 1:%Ld, prio %d, %d ops") raw_level fitness priority
            op_count in
        let ctxt := Alpha_context.finalize (Some commit_message) ctxt in
        Error_monad.__return (ctxt, receipt))
  end.

Definition compare_operations
  (op1 : Alpha_context.packed_operation) (op2 : Alpha_context.packed_operation)
  : Z :=
  let 'Alpha_context.Operation_data op1 :=
    Alpha_context.packed_operation.protocol_data op1 in
  let 'Alpha_context.Operation_data op2 :=
    Alpha_context.packed_operation.protocol_data op2 in
  match
    ((Alpha_context.protocol_data.contents op1),
      (Alpha_context.protocol_data.contents op2)) with
  |
    (Alpha_context.Single (Alpha_context.Endorsement _),
      Alpha_context.Single (Alpha_context.Endorsement _)) => 0
  | (_, Alpha_context.Single (Alpha_context.Endorsement _)) => 1
  | (Alpha_context.Single (Alpha_context.Endorsement _), _) => (-1)
  |
    (Alpha_context.Single (Alpha_context.Seed_nonce_revelation _),
      Alpha_context.Single (Alpha_context.Seed_nonce_revelation _)) => 0
  | (_, Alpha_context.Single (Alpha_context.Seed_nonce_revelation _)) => 1
  | (Alpha_context.Single (Alpha_context.Seed_nonce_revelation _), _) => (-1)
  |
    (Alpha_context.Single (Alpha_context.Double_endorsement_evidence _),
      Alpha_context.Single (Alpha_context.Double_endorsement_evidence _)) => 0
  | (_, Alpha_context.Single (Alpha_context.Double_endorsement_evidence _)) => 1
  | (Alpha_context.Single (Alpha_context.Double_endorsement_evidence _), _) =>
    (-1)
  |
    (Alpha_context.Single (Alpha_context.Double_baking_evidence _),
      Alpha_context.Single (Alpha_context.Double_baking_evidence _)) => 0
  | (_, Alpha_context.Single (Alpha_context.Double_baking_evidence _)) => 1
  | (Alpha_context.Single (Alpha_context.Double_baking_evidence _), _) => (-1)
  |
    (Alpha_context.Single (Alpha_context.Activate_account _),
      Alpha_context.Single (Alpha_context.Activate_account _)) => 0
  | (_, Alpha_context.Single (Alpha_context.Activate_account _)) => 1
  | (Alpha_context.Single (Alpha_context.Activate_account _), _) => (-1)
  |
    (Alpha_context.Single (Alpha_context.Proposals _),
      Alpha_context.Single (Alpha_context.Proposals _)) => 0
  | (_, Alpha_context.Single (Alpha_context.Proposals _)) => 1
  | (Alpha_context.Single (Alpha_context.Proposals _), _) => (-1)
  |
    (Alpha_context.Single (Alpha_context.Ballot _),
      Alpha_context.Single (Alpha_context.Ballot _)) => 0
  | (_, Alpha_context.Single (Alpha_context.Ballot _)) => 1
  | (Alpha_context.Single (Alpha_context.Ballot _), _) => (-1)
  |
    (Alpha_context.Single (Alpha_context.Manager_operation op1),
      Alpha_context.Single (Alpha_context.Manager_operation op2)) =>
    Z.compare (Alpha_context.contents.Manager_operation.counter op1)
      (Alpha_context.contents.Manager_operation.counter op2)
  |
    (Alpha_context.Cons (Alpha_context.Manager_operation op1) _,
      Alpha_context.Single (Alpha_context.Manager_operation op2)) =>
    Z.compare (Alpha_context.contents.Manager_operation.counter op1)
      (Alpha_context.contents.Manager_operation.counter op2)
  |
    (Alpha_context.Single (Alpha_context.Manager_operation op1),
      Alpha_context.Cons (Alpha_context.Manager_operation op2) _) =>
    Z.compare (Alpha_context.contents.Manager_operation.counter op1)
      (Alpha_context.contents.Manager_operation.counter op2)
  |
    (Alpha_context.Cons (Alpha_context.Manager_operation op1) _,
      Alpha_context.Cons (Alpha_context.Manager_operation op2) _) =>
    Z.compare (Alpha_context.contents.Manager_operation.counter op1)
      (Alpha_context.contents.Manager_operation.counter op2)
  end.

Definition init (ctxt : Context.t) (block_header : Block_header.shell_header)
  : Lwt.t (Error_monad.tzresult Updater.validation_result) :=
  let level := Block_header.shell_header.level block_header in
  let fitness := Block_header.shell_header.fitness block_header in
  let timestamp := Block_header.shell_header.timestamp block_header in
  let typecheck (ctxt : Alpha_context.context) (script : Alpha_context.Script.t)
    : Lwt.t
      (Error_monad.tzresult
        ((Alpha_context.Script.t * option Alpha_context.Contract.big_map_diff) *
          Alpha_context.context)) :=
    Error_monad.op_gtgteqquestion
      (Script_ir_translator.parse_script None ctxt false script)
      (fun function_parameter =>
        let '(Script_ir_translator.Ex_script parsed_script, ctxt) :=
          function_parameter in
        Error_monad.op_gtgteqquestion
          (Script_ir_translator.extract_big_map_diff ctxt
            Script_ir_translator.Optimized false
            Script_ir_translator.no_big_map_id
            Script_ir_translator.no_big_map_id
            (Script_typed_ir.script.storage_type parsed_script)
            (Script_typed_ir.script.storage parsed_script))
          (fun function_parameter =>
            let '(storage, big_map_diff, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion
              (Script_ir_translator.unparse_data ctxt
                Script_ir_translator.Optimized
                (Script_typed_ir.script.storage_type parsed_script) storage)
              (fun function_parameter =>
                let '(storage, ctxt) := function_parameter in
                let storage :=
                  Alpha_context.Script.__lazy_expr_value
                    (Micheline.strip_locations storage) in
                Error_monad.__return
                  (((Alpha_context.Script.t.with_storage storage script),
                    big_map_diff), ctxt)))) in
  Error_monad.op_gtgteqquestion
    (Alpha_context.prepare_first_block ctxt typecheck level timestamp fitness)
    (fun ctxt => Error_monad.__return (Alpha_context.finalize None ctxt)).

Main_mli

  • OCaml size: 69 lines
  • Coq size: 187 lines (+171% compared to OCaml)
main.mli 2 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Implementation - Protocol Signature Instance *)

type validation_mode =
  | Application of {
      block_header : Alpha_context.Block_header.t;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }
  | Partial_application of {
      block_header : Alpha_context.Block_header.t;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }
  | Partial_construction of {predecessor : Block_hash.t}
  | Full_construction of {
      predecessor : Block_hash.t;
      protocol_data : Alpha_context.Block_header.contents;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }

type validation_state = {
  mode : validation_mode;
  chain_id : Chain_id.t;
  ctxt : Alpha_context.t;
  op_count : int;
}

type operation_data = Alpha_context.packed_protocol_data

type operation = Alpha_context.packed_operation = {
  shell : Operation.shell_header;
  protocol_data : operation_data;
}

include
  Updater.PROTOCOL
    with type block_header_data = Alpha_context.Block_header.protocol_data
     and type block_header_metadata = Apply_results.block_metadata
     and type block_header = Alpha_context.Block_header.t
     and type operation_data := operation_data
     and type operation_receipt = Apply_results.packed_operation_metadata
     and type operation := operation
     and type validation_state := validation_state
Main_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Apply_results.

Module validation_mode.
  Module Application.
    Record record {block_header baker block_delay : Set} := {
      block_header : block_header;
      baker : baker;
      block_delay : block_delay }.
    Arguments record : clear implicits.
  End Application.
  Definition Application_skeleton := Application.record.
  
  Module Partial_application.
    Record record {block_header baker block_delay : Set} := {
      block_header : block_header;
      baker : baker;
      block_delay : block_delay }.
    Arguments record : clear implicits.
  End Partial_application.
  Definition Partial_application_skeleton := Partial_application.record.
  
  Module Partial_construction.
    Record record {predecessor : Set} := {
      predecessor : predecessor }.
    Arguments record : clear implicits.
  End Partial_construction.
  Definition Partial_construction_skeleton := Partial_construction.record.
  
  Module Full_construction.
    Record record {predecessor protocol_data baker block_delay : Set} := {
      predecessor : predecessor;
      protocol_data : protocol_data;
      baker : baker;
      block_delay : block_delay }.
    Arguments record : clear implicits.
  End Full_construction.
  Definition Full_construction_skeleton := Full_construction.record.
End validation_mode.

Reserved Notation "'validation_mode.Application".
Reserved Notation "'validation_mode.Partial_application".
Reserved Notation "'validation_mode.Partial_construction".
Reserved Notation "'validation_mode.Full_construction".

Inductive validation_mode : Set :=
| Application : 'validation_mode.Application -> validation_mode
| Partial_application : 'validation_mode.Partial_application -> validation_mode
| Partial_construction :
  'validation_mode.Partial_construction -> validation_mode
| Full_construction : 'validation_mode.Full_construction -> validation_mode

where "'validation_mode.Application" :=
  (validation_mode.Application_skeleton Alpha_context.Block_header.t
    Alpha_context.public_key_hash Alpha_context.Period.t)
and "'validation_mode.Partial_application" :=
  (validation_mode.Partial_application_skeleton Alpha_context.Block_header.t
    Alpha_context.public_key_hash Alpha_context.Period.t)
and "'validation_mode.Partial_construction" :=
  (validation_mode.Partial_construction_skeleton (|Block_hash|).(S.HASH.t))
and "'validation_mode.Full_construction" :=
  (validation_mode.Full_construction_skeleton (|Block_hash|).(S.HASH.t)
    Alpha_context.Block_header.contents Alpha_context.public_key_hash
    Alpha_context.Period.t).

Module ConstructorRecordNotations_validation_mode.
  Module validation_mode.
    Definition Application := 'validation_mode.Application.
    Definition Partial_application := 'validation_mode.Partial_application.
    Definition Partial_construction := 'validation_mode.Partial_construction.
    Definition Full_construction := 'validation_mode.Full_construction.
  End validation_mode.
End ConstructorRecordNotations_validation_mode.
Import ConstructorRecordNotations_validation_mode.

Module validation_state.
  Record record := Build {
    mode : validation_mode;
    chain_id : (|Chain_id|).(S.HASH.t);
    ctxt : Alpha_context.t;
    op_count : Z }.
  Definition with_mode mode (r : record) :=
    Build mode r.(chain_id) r.(ctxt) r.(op_count).
  Definition with_chain_id chain_id (r : record) :=
    Build r.(mode) chain_id r.(ctxt) r.(op_count).
  Definition with_ctxt ctxt (r : record) :=
    Build r.(mode) r.(chain_id) ctxt r.(op_count).
  Definition with_op_count op_count (r : record) :=
    Build r.(mode) r.(chain_id) r.(ctxt) op_count.
End validation_state.
Definition validation_state := validation_state.record.

Definition operation_data := Alpha_context.packed_protocol_data.

Module operation.
  Record record := Build {
    shell : Operation.shell_header;
    protocol_data : operation_data }.
  Definition with_shell shell (r : record) :=
    Build shell r.(protocol_data).
  Definition with_protocol_data protocol_data (r : record) :=
    Build r.(shell) protocol_data.
End operation.
Definition operation := operation.record.

Parameter Included_PROTOCOL :
  {'[block_header, operation] : _ &
    Updater.PROTOCOL.signature Alpha_context.Block_header.protocol_data
      block_header Apply_results.block_metadata operation_data
      Apply_results.packed_operation_metadata operation validation_state}.

Definition max_block_length :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.max_block_length).

Definition max_operation_data_length :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.max_operation_data_length).

Definition validation_passes :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.validation_passes).

Definition block_header_data :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.block_header_data).

Definition block_header_data_encoding :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.block_header_data_encoding).

Definition block_header :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.block_header).

Definition block_header_metadata :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.block_header_metadata).

Definition block_header_metadata_encoding :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.block_header_metadata_encoding).

Definition operation_receipt :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.operation_receipt).

Definition operation_data_encoding :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.operation_data_encoding).

Definition operation_receipt_encoding :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.operation_receipt_encoding).

Definition operation_data_and_receipt_encoding :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.operation_data_and_receipt_encoding).

Definition acceptable_passes :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.acceptable_passes).

Definition compare_operations :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.compare_operations).

Definition current_context :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.current_context).

Definition begin_partial_application :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.begin_partial_application).

Definition begin_application :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.begin_application).

Definition begin_construction :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.begin_construction).

Definition apply_operation :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.apply_operation).

Definition finalize_block :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.finalize_block).

Definition rpc_services :=
(|Included_PROTOCOL|).(Updater.PROTOCOL.rpc_services).

Definition init := (|Included_PROTOCOL|).(Updater.PROTOCOL.init).

Manager_repr

  • OCaml size: 52 lines
  • Coq size: 44 lines (-16% compared to OCaml)
manager_repr.ml success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Low level Repr. of Managers' keys *)

type manager_key =
  | Hash of Signature.Public_key_hash.t
  | Public_key of Signature.Public_key.t

type t = manager_key

open Data_encoding

let hash_case tag =
  case
    tag
    ~title:"Public_key_hash"
    Signature.Public_key_hash.encoding
    (function Hash hash -> Some hash | _ -> None)
    (fun hash -> Hash hash)

let pubkey_case tag =
  case
    tag
    ~title:"Public_key"
    Signature.Public_key.encoding
    (function Public_key hash -> Some hash | _ -> None)
    (fun hash -> Public_key hash)

let encoding = union [hash_case (Tag 0); pubkey_case (Tag 1)]
Manager_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Inductive manager_key : Set :=
| Hash : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> manager_key
| Public_key : (|Signature.Public_key|).(S.SPublic_key.t) -> manager_key.

Definition t := manager_key.

Import Data_encoding.

Definition hash_case (tag : Data_encoding.case_tag)
  : Data_encoding.case manager_key :=
  Data_encoding.__case_value "Public_key_hash" None tag
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding)
    (fun function_parameter =>
      match function_parameter with
      | Hash __hash_value => Some __hash_value
      | _ => None
      end) (fun __hash_value => Hash __hash_value).

Definition pubkey_case (tag : Data_encoding.case_tag)
  : Data_encoding.case manager_key :=
  Data_encoding.__case_value "Public_key" None tag
    (|Signature.Public_key|).(S.SPublic_key.encoding)
    (fun function_parameter =>
      match function_parameter with
      | Public_key __hash_value => Some __hash_value
      | _ => None
      end) (fun __hash_value => Public_key __hash_value).

Definition encoding : Data_encoding.encoding manager_key :=
  Data_encoding.union None
    [ hash_case (Data_encoding.Tag 0); pubkey_case (Data_encoding.Tag 1) ].

Manager_repr_mli

  • OCaml size: 38 lines
  • Coq size: 20 lines (-48% compared to OCaml)
manager_repr.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Low level Repr. of Managers' keys *)

(** The public key of the manager of a contract is reveled only after the
    first operation. At Origination time, the manager provides only the hash
    of its public key that is stored in the contract. When the public key
    is actually reveeld, the public key instead of the hash of the key *)
type manager_key =
  | Hash of Signature.Public_key_hash.t
  | Public_key of Signature.Public_key.t

type t = manager_key

val encoding : t Data_encoding.encoding
Manager_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Inductive manager_key : Set :=
| Hash : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> manager_key
| Public_key : (|Signature.Public_key|).(S.SPublic_key.t) -> manager_key.

Definition t := manager_key.

Parameter encoding : Data_encoding.encoding t.

Michelson_v1_gas

  • OCaml size: 765 lines
  • Coq size: 877 lines (+14% compared to OCaml)
michelson_v1_gas.ml 2 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Gas

module Cost_of = struct
  let log2 =
    let rec help acc = function 0 -> acc | n -> help (acc + 1) (n / 2) in
    help 1

  let z_bytes (z : Z.t) =
    let bits = Z.numbits z in
    (7 + bits) / 8

  let int_bytes (z : 'a Script_int.num) = z_bytes (Script_int.to_zint z)

  let timestamp_bytes (t : Script_timestamp.t) =
    let z = Script_timestamp.to_zint t in
    z_bytes z

  (* For now, returns size in bytes, but this could get more complicated... *)
  let rec size_of_comparable :
      type a b. (a, b) Script_typed_ir.comparable_struct -> a -> int =
   fun wit v ->
    match wit with
    | Int_key _ ->
        int_bytes v
    | Nat_key _ ->
        int_bytes v
    | String_key _ ->
        String.length v
    | Bytes_key _ ->
        MBytes.length v
    | Bool_key _ ->
        8
    | Key_hash_key _ ->
        Signature.Public_key_hash.size
    | Timestamp_key _ ->
        timestamp_bytes v
    | Address_key _ ->
        Signature.Public_key_hash.size
    | Mutez_key _ ->
        8
    | Pair_key ((l, _), (r, _), _) ->
        let (lval, rval) = v in
        size_of_comparable l lval + size_of_comparable r rval

  let string length = alloc_bytes_cost length

  let bytes length = alloc_mbytes_cost length

  let manager_operation = step_cost 10_000

  module Legacy = struct
    let zint z = alloc_bits_cost (Z.numbits z)

    let set_to_list : type item. item Script_typed_ir.set -> cost =
     fun (module Box) -> alloc_cost @@ Pervasives.(Box.size * 2)

    let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost
        =
     fun (module Box) ->
      let size = snd Box.boxed in
      3 *@ alloc_cost size

    let z_to_int64 = step_cost 2 +@ alloc_cost 1

    let hash data len = (10 *@ step_cost (MBytes.length data)) +@ bytes len

    let set_access : type elt. elt -> elt Script_typed_ir.set -> int =
     fun _key (module Box) -> log2 @@ Box.size

    let set_update key _presence set = set_access key set *@ alloc_cost 3
  end

  module Interpreter = struct
    let cycle = atomic_step_cost 10

    let nop = free

    let stack_op = atomic_step_cost 10

    let push = atomic_step_cost 10

    let wrap = atomic_step_cost 10

    let variant_no_data = atomic_step_cost 10

    let branch = atomic_step_cost 10

    let pair = atomic_step_cost 10

    let pair_access = atomic_step_cost 10

    let cons = atomic_step_cost 10

    let loop_size = atomic_step_cost 5

    let loop_cycle = atomic_step_cost 10

    let loop_iter = atomic_step_cost 20

    let loop_map = atomic_step_cost 30

    let empty_set = atomic_step_cost 10

    let set_to_list : type elt. elt Script_typed_ir.set -> cost =
     fun (module Box) -> atomic_step_cost (Box.size * 20)

    let set_mem : type elt. elt -> elt Script_typed_ir.set -> cost =
     fun elt (module Box) ->
      let elt_bytes = size_of_comparable Box.elt_ty elt in
      atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size)

    let set_update : type elt. elt -> bool -> elt Script_typed_ir.set -> cost =
     fun elt _ (module Box) ->
      let elt_bytes = size_of_comparable Box.elt_ty elt in
      atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size)

    let set_size = atomic_step_cost 10

    let empty_map = atomic_step_cost 10

    let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost
        =
     fun (module Box) ->
      let size = snd Box.boxed in
      atomic_step_cost (size * 20)

    let map_access :
        type key value. key -> (key, value) Script_typed_ir.map -> cost =
     fun key (module Box) ->
      let map_card = snd Box.boxed in
      let key_bytes = size_of_comparable Box.key_ty key in
      atomic_step_cost ((1 + (key_bytes / 70)) * log2 map_card)

    let map_mem = map_access

    let map_get = map_access

    let map_update :
        type key value.
        key -> value option -> (key, value) Script_typed_ir.map -> cost =
     fun key _value (module Box) ->
      let map_card = snd Box.boxed in
      let key_bytes = size_of_comparable Box.key_ty key in
      atomic_step_cost ((1 + (key_bytes / 38)) * log2 map_card)

    let map_size = atomic_step_cost 10

    let add_timestamp (t1 : Script_timestamp.t) (t2 : 'a Script_int.num) =
      let bytes1 = timestamp_bytes t1 in
      let bytes2 = int_bytes t2 in
      atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62))

    let sub_timestamp = add_timestamp

    let diff_timestamps (t1 : Script_timestamp.t) (t2 : Script_timestamp.t) =
      let bytes1 = timestamp_bytes t1 in
      let bytes2 = timestamp_bytes t2 in
      atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62))

    let rec concat_loop l acc =
      match l with [] -> 30 | _ :: tl -> concat_loop tl (acc + 30)

    let concat_string string_list =
      atomic_step_cost (concat_loop string_list 0)

    let slice_string string_length =
      atomic_step_cost (40 + (string_length / 70))

    let concat_bytes bytes_list = atomic_step_cost (concat_loop bytes_list 0)

    let int64_op = atomic_step_cost 61

    let z_to_int64 = atomic_step_cost 20

    let int64_to_z = atomic_step_cost 20

    let bool_binop _ _ = atomic_step_cost 10

    let bool_unop _ = atomic_step_cost 10

    let abs int = atomic_step_cost (61 + (int_bytes int / 70))

    let int _int = free

    let neg = abs

    let add i1 i2 =
      atomic_step_cost
        (51 + (Compare.Int.max (int_bytes i1) (int_bytes i2) / 62))

    let sub = add

    let mul i1 i2 =
      let bytes = Compare.Int.max (int_bytes i1) (int_bytes i2) in
      atomic_step_cost (51 + (bytes / 6 * log2 bytes))

    let indic_lt x y = if Compare.Int.(x < y) then 1 else 0

    let div i1 i2 =
      let bytes1 = int_bytes i1 in
      let bytes2 = int_bytes i2 in
      let cost = indic_lt bytes2 bytes1 * (bytes1 - bytes2) * bytes2 in
      atomic_step_cost (51 + (cost / 3151))

    let shift_left _i _shift_bits = atomic_step_cost 30

    let shift_right _i _shift_bits = atomic_step_cost 30

    let logor i1 i2 =
      let bytes1 = int_bytes i1 in
      let bytes2 = int_bytes i2 in
      atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 70))

    let logand i1 i2 =
      let bytes1 = int_bytes i1 in
      let bytes2 = int_bytes i2 in
      atomic_step_cost (51 + (Compare.Int.min bytes1 bytes2 / 70))

    let logxor = logor

    let lognot i = atomic_step_cost (51 + (int_bytes i / 20))

    let exec = atomic_step_cost 10

    let compare_bool _ _ = atomic_step_cost 30

    let compare_string s1 s2 =
      let bytes1 = String.length s1 in
      let bytes2 = String.length s2 in
      atomic_step_cost (30 + (Compare.Int.min bytes1 bytes2 / 123))

    let compare_bytes b1 b2 =
      let bytes1 = MBytes.length b1 in
      let bytes2 = MBytes.length b2 in
      atomic_step_cost (30 + (Compare.Int.min bytes1 bytes2 / 123))

    let compare_tez _ _ = atomic_step_cost 30

    let compare_zint i1 i2 =
      atomic_step_cost
        (51 + (Compare.Int.min (int_bytes i1) (int_bytes i2) / 82))

    let compare_key_hash _ _ = atomic_step_cost 92

    let compare_timestamp t1 t2 =
      let bytes1 = timestamp_bytes t1 in
      let bytes2 = timestamp_bytes t2 in
      atomic_step_cost (51 + (Compare.Int.min bytes1 bytes2 / 82))

    let compare_address _ _ = atomic_step_cost 92

    let compare_res = atomic_step_cost 30

    let unpack_failed bytes =
      (* We cannot instrument failed deserialization,
         so we take worst case fees: a set of size 1 bytes values. *)
      let len = MBytes.length bytes in
      (len *@ alloc_mbytes_cost 1)
      +@ (len *@ (log2 len *@ (alloc_cost 3 +@ step_cost 1)))

    let address = atomic_step_cost 10

    let contract = step_cost 10000

    let transfer = step_cost 10

    let create_account = step_cost 10

    let create_contract = step_cost 10

    let implicit_account = step_cost 10

    let set_delegate = step_cost 10 +@ write_bytes_cost (Z.of_int 32)

    let balance = atomic_step_cost 10

    let now = atomic_step_cost 10

    let check_signature_secp256k1 bytes = atomic_step_cost (10342 + (bytes / 5))

    let check_signature_ed25519 bytes = atomic_step_cost (36864 + (bytes / 5))

    let check_signature_p256 bytes = atomic_step_cost (36864 + (bytes / 5))

    let check_signature (pkey : Signature.public_key) bytes =
      match pkey with
      | Ed25519 _ ->
          check_signature_ed25519 (MBytes.length bytes)
      | Secp256k1 _ ->
          check_signature_secp256k1 (MBytes.length bytes)
      | P256 _ ->
          check_signature_p256 (MBytes.length bytes)

    let hash_key = atomic_step_cost 30

    let hash_blake2b b = atomic_step_cost (102 + (MBytes.length b / 5))

    let hash_sha256 b = atomic_step_cost (409 + MBytes.length b)

    let hash_sha512 b =
      let bytes = MBytes.length b in
      atomic_step_cost (409 + ((bytes lsr 1) + (bytes lsr 4)))

    let steps_to_quota = atomic_step_cost 10

    let source = atomic_step_cost 10

    let self = atomic_step_cost 10

    let amount = atomic_step_cost 10

    let chain_id = step_cost 1

    let stack_n_op n =
      atomic_step_cost (20 + ((n lsr 1) + (n lsr 2) + (n lsr 4)))

    let apply = alloc_cost 8 +@ step_cost 1

    let rec compare :
        type a s. (a, s) Script_typed_ir.comparable_struct -> a -> a -> cost =
     fun ty x y ->
      match ty with
      | Bool_key _ ->
          compare_bool x y
      | String_key _ ->
          compare_string x y
      | Bytes_key _ ->
          compare_bytes x y
      | Mutez_key _ ->
          compare_tez x y
      | Int_key _ ->
          compare_zint x y
      | Nat_key _ ->
          compare_zint x y
      | Key_hash_key _ ->
          compare_key_hash x y
      | Timestamp_key _ ->
          compare_timestamp x y
      | Address_key _ ->
          compare_address x y
      | Pair_key ((tl, _), (tr, _), _) ->
          (* Reasonable over-approximation of the cost of lexicographic comparison. *)
          let (xl, xr) = x and (yl, yr) = y in
          compare tl xl yl +@ compare tr xr yr
  end

  module Typechecking = struct
    let cycle = step_cost 1

    let bool = free

    let unit = free

    let string = string

    let bytes = bytes

    let z = Legacy.zint

    let int_of_string str =
      alloc_cost @@ Pervasives.( / ) (String.length str) 5

    let tez = step_cost 1 +@ alloc_cost 1

    let string_timestamp = step_cost 3 +@ alloc_cost 3

    let key = step_cost 3 +@ alloc_cost 3

    let key_hash = step_cost 1 +@ alloc_cost 1

    let signature = step_cost 1 +@ alloc_cost 1

    let chain_id = step_cost 1 +@ alloc_cost 1

    let contract = step_cost 5

    let get_script = step_cost 20 +@ alloc_cost 5

    let contract_exists = step_cost 15 +@ alloc_cost 5

    let pair = alloc_cost 2

    let union = alloc_cost 1

    let lambda = alloc_cost 5 +@ step_cost 3

    let some = alloc_cost 1

    let none = alloc_cost 0

    let list_element = alloc_cost 2 +@ step_cost 1

    let set_element size = log2 size *@ (alloc_cost 3 +@ step_cost 2)

    let map_element size = log2 size *@ (alloc_cost 4 +@ step_cost 2)

    let primitive_type = alloc_cost 1

    let one_arg_type = alloc_cost 2

    let two_arg_type = alloc_cost 3

    let operation b = bytes b

    let type_ nb_args = alloc_cost (nb_args + 1)

    (* Cost of parsing instruction, is cost of allocation of
       constructor + cost of contructor parameters + cost of
       allocation on the stack type *)
    let instr : type b a. (b, a) Script_typed_ir.instr -> cost =
     fun i ->
      let open Script_typed_ir in
      alloc_cost 1
      +@
      (* cost of allocation of constructor *)
      match i with
      | Drop ->
          alloc_cost 0
      | Dup ->
          alloc_cost 1
      | Swap ->
          alloc_cost 0
      | Const _ ->
          alloc_cost 1
      | Cons_pair ->
          alloc_cost 2
      | Car ->
          alloc_cost 1
      | Cdr ->
          alloc_cost 1
      | Cons_some ->
          alloc_cost 2
      | Cons_none _ ->
          alloc_cost 3
      | If_none _ ->
          alloc_cost 2
      | Left ->
          alloc_cost 3
      | Right ->
          alloc_cost 3
      | If_left _ ->
          alloc_cost 2
      | Cons_list ->
          alloc_cost 1
      | Nil ->
          alloc_cost 1
      | If_cons _ ->
          alloc_cost 2
      | List_map _ ->
          alloc_cost 5
      | List_iter _ ->
          alloc_cost 4
      | List_size ->
          alloc_cost 1
      | Empty_set _ ->
          alloc_cost 1
      | Set_iter _ ->
          alloc_cost 4
      | Set_mem ->
          alloc_cost 1
      | Set_update ->
          alloc_cost 1
      | Set_size ->
          alloc_cost 1
      | Empty_map _ ->
          alloc_cost 2
      | Map_map _ ->
          alloc_cost 5
      | Map_iter _ ->
          alloc_cost 4
      | Map_mem ->
          alloc_cost 1
      | Map_get ->
          alloc_cost 1
      | Map_update ->
          alloc_cost 1
      | Map_size ->
          alloc_cost 1
      | Empty_big_map _ ->
          alloc_cost 2
      | Big_map_mem ->
          alloc_cost 1
      | Big_map_get ->
          alloc_cost 1
      | Big_map_update ->
          alloc_cost 1
      | Concat_string ->
          alloc_cost 1
      | Concat_string_pair ->
          alloc_cost 1
      | Concat_bytes ->
          alloc_cost 1
      | Concat_bytes_pair ->
          alloc_cost 1
      | Slice_string ->
          alloc_cost 1
      | Slice_bytes ->
          alloc_cost 1
      | String_size ->
          alloc_cost 1
      | Bytes_size ->
          alloc_cost 1
      | Add_seconds_to_timestamp ->
          alloc_cost 1
      | Add_timestamp_to_seconds ->
          alloc_cost 1
      | Sub_timestamp_seconds ->
          alloc_cost 1
      | Diff_timestamps ->
          alloc_cost 1
      | Add_tez ->
          alloc_cost 1
      | Sub_tez ->
          alloc_cost 1
      | Mul_teznat ->
          alloc_cost 1
      | Mul_nattez ->
          alloc_cost 1
      | Ediv_teznat ->
          alloc_cost 1
      | Ediv_tez ->
          alloc_cost 1
      | Or ->
          alloc_cost 1
      | And ->
          alloc_cost 1
      | Xor ->
          alloc_cost 1
      | Not ->
          alloc_cost 1
      | Is_nat ->
          alloc_cost 1
      | Neg_nat ->
          alloc_cost 1
      | Neg_int ->
          alloc_cost 1
      | Abs_int ->
          alloc_cost 1
      | Int_nat ->
          alloc_cost 1
      | Add_intint ->
          alloc_cost 1
      | Add_intnat ->
          alloc_cost 1
      | Add_natint ->
          alloc_cost 1
      | Add_natnat ->
          alloc_cost 1
      | Sub_int ->
          alloc_cost 1
      | Mul_intint ->
          alloc_cost 1
      | Mul_intnat ->
          alloc_cost 1
      | Mul_natint ->
          alloc_cost 1
      | Mul_natnat ->
          alloc_cost 1
      | Ediv_intint ->
          alloc_cost 1
      | Ediv_intnat ->
          alloc_cost 1
      | Ediv_natint ->
          alloc_cost 1
      | Ediv_natnat ->
          alloc_cost 1
      | Lsl_nat ->
          alloc_cost 1
      | Lsr_nat ->
          alloc_cost 1
      | Or_nat ->
          alloc_cost 1
      | And_nat ->
          alloc_cost 1
      | And_int_nat ->
          alloc_cost 1
      | Xor_nat ->
          alloc_cost 1
      | Not_nat ->
          alloc_cost 1
      | Not_int ->
          alloc_cost 1
      | Seq _ ->
          alloc_cost 8
      | If _ ->
          alloc_cost 8
      | Loop _ ->
          alloc_cost 4
      | Loop_left _ ->
          alloc_cost 5
      | Dip _ ->
          alloc_cost 4
      | Exec ->
          alloc_cost 1
      | Apply _ ->
          alloc_cost 1
      | Lambda _ ->
          alloc_cost 2
      | Failwith _ ->
          alloc_cost 1
      | Nop ->
          alloc_cost 0
      | Compare _ ->
          alloc_cost 1
      | Eq ->
          alloc_cost 1
      | Neq ->
          alloc_cost 1
      | Lt ->
          alloc_cost 1
      | Gt ->
          alloc_cost 1
      | Le ->
          alloc_cost 1
      | Ge ->
          alloc_cost 1
      | Address ->
          alloc_cost 1
      | Contract _ ->
          alloc_cost 2
      | Transfer_tokens ->
          alloc_cost 1
      | Create_account ->
          alloc_cost 2
      | Implicit_account ->
          alloc_cost 1
      | Create_contract _ ->
          alloc_cost 8
      (* Deducted the cost of removed arguments manager, spendable and delegatable:
           - manager: key_hash = 1
           - spendable: bool = 0
           - delegatable: bool = 0
        *)
      | Create_contract_2 _ ->
          alloc_cost 7
      | Set_delegate ->
          alloc_cost 1
      | Now ->
          alloc_cost 1
      | Balance ->
          alloc_cost 1
      | Check_signature ->
          alloc_cost 1
      | Hash_key ->
          alloc_cost 1
      | Pack _ ->
          alloc_cost 2
      | Unpack _ ->
          alloc_cost 2
      | Blake2b ->
          alloc_cost 1
      | Sha256 ->
          alloc_cost 1
      | Sha512 ->
          alloc_cost 1
      | Steps_to_quota ->
          alloc_cost 1
      | Source ->
          alloc_cost 1
      | Sender ->
          alloc_cost 1
      | Self _ ->
          alloc_cost 2
      | Amount ->
          alloc_cost 1
      | Dig (n, _) ->
          n *@ alloc_cost 1 (* _ is a unary development of n *)
      | Dug (n, _) ->
          n *@ alloc_cost 1
      | Dipn (n, _, _) ->
          n *@ alloc_cost 1
      | Dropn (n, _) ->
          n *@ alloc_cost 1
      | ChainId ->
          alloc_cost 1
  end

  module Unparse = struct
    let prim_cost l annot = Script.prim_node_cost_nonrec_of_length l annot

    let seq_cost = Script.seq_node_cost_nonrec_of_length

    let string_cost length = Script.string_node_cost_of_length length

    let cycle = step_cost 1

    let bool = prim_cost 0 []

    let unit = prim_cost 0 []

    (* We count the length of strings and bytes to prevent hidden
       miscalculations due to non detectable expansion of sharing. *)
    let string s = Script.string_node_cost s

    let bytes s = Script.bytes_node_cost s

    let z i = Script.int_node_cost i

    let int i = Script.int_node_cost (Script_int.to_zint i)

    let tez = Script.int_node_cost_of_numbits 60 (* int64 bound *)

    let timestamp x = Script_timestamp.to_zint x |> Script_int.of_zint |> int

    let operation bytes = Script.bytes_node_cost bytes

    let chain_id bytes = Script.bytes_node_cost bytes

    let key = string_cost 54

    let key_hash = string_cost 36

    let signature = string_cost 128

    let contract = string_cost 36

    let pair = prim_cost 2 []

    let union = prim_cost 1 []

    let some = prim_cost 1 []

    let none = prim_cost 0 []

    let list_element = alloc_cost 2

    let set_element = alloc_cost 2

    let map_element = alloc_cost 2

    let one_arg_type = prim_cost 1

    let two_arg_type = prim_cost 2

    let set_to_list = Legacy.set_to_list

    let map_to_list = Legacy.map_to_list
  end
end
Michelson_v1_gas.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Script_typed_ir.

Import Alpha_context.

Import Gas.

Module Cost_of.
  Definition log2 : Z -> Z :=
    let fix help (acc : Z) (function_parameter : Z) {struct acc} : Z :=
      match function_parameter with
      | 0 => acc
      | n => help (Pervasives.op_plus acc 1) (Pervasives.op_div n 2)
      end in
    help 1.
  
  Definition z_bytes (z : Z.t) : Z :=
    let bits := Z.numbits z in
    Pervasives.op_div (Pervasives.op_plus 7 bits) 8.
  
  Definition int_bytes {a : Set} (z : Alpha_context.Script_int.num a) : Z :=
    z_bytes (Alpha_context.Script_int.to_zint z).
  
  Definition timestamp_bytes (__t_value : Alpha_context.Script_timestamp.t)
    : Z :=
    let z := Alpha_context.Script_timestamp.to_zint __t_value in
    z_bytes z.
  
  Fixpoint size_of_comparable {a b : Set}
    (wit : Script_typed_ir.comparable_struct a b) (v : a) {struct wit} : Z :=
    match wit with
    | Script_typed_ir.Int_key _ => int_bytes v
    | Script_typed_ir.Nat_key _ => int_bytes v
    | Script_typed_ir.String_key _ => String.length v
    | Script_typed_ir.Bytes_key _ => MBytes.length v
    | Script_typed_ir.Bool_key _ => 8
    | Script_typed_ir.Key_hash_key _ =>
      (|Signature.Public_key_hash|).(S.SPublic_key_hash.size)
    | Script_typed_ir.Timestamp_key _ => timestamp_bytes v
    | Script_typed_ir.Address_key _ =>
      (|Signature.Public_key_hash|).(S.SPublic_key_hash.size)
    | Script_typed_ir.Mutez_key _ => 8
    | Script_typed_ir.Pair_key (l, _) (r, _) _ =>
      let '(lval, rval) := v in
      Pervasives.op_plus (size_of_comparable l lval) (size_of_comparable r rval)
    end.
  
  Definition __string_value (length : Z) : Alpha_context.Gas.cost :=
    Alpha_context.Gas.alloc_bytes_cost length.
  
  Definition __bytes_value (length : Z) : Alpha_context.Gas.cost :=
    Alpha_context.Gas.alloc_mbytes_cost length.
  
  Definition manager_operation : Alpha_context.Gas.cost :=
    Alpha_context.Gas.step_cost 10000.
  
  Module Legacy.
    Definition zint (z : Z.t) : Alpha_context.Gas.cost :=
      Alpha_context.Gas.alloc_bits_cost (Z.numbits z).
    
    Definition set_to_list {item : Set} (Box : Script_typed_ir.set item)
      : Alpha_context.Gas.cost :=
      Pervasives.op_atat Alpha_context.Gas.alloc_cost
        (Pervasives.op_star (|Box|).(Script_typed_ir.Boxed_set.size) 2).
    
    Definition map_to_list {key value : Set}
      (Box : Script_typed_ir.map key value) : Alpha_context.Gas.cost :=
      let size := Pervasives.snd (|Box|).(Script_typed_ir.Boxed_map.boxed) in
      Alpha_context.Gas.op_starat 3 (Alpha_context.Gas.alloc_cost size).
    
    Definition z_to_int64 : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_plusat (Alpha_context.Gas.step_cost 2)
        (Alpha_context.Gas.alloc_cost 1).
    
    Definition __hash_value (data : MBytes.t) (len : Z)
      : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_plusat
        (Alpha_context.Gas.op_starat 10
          (Alpha_context.Gas.step_cost (MBytes.length data)))
        (__bytes_value len).
    
    Definition set_access {elt : Set}
      (_key : elt) (Box : Script_typed_ir.set elt) : Z :=
      Pervasives.op_atat log2 (|Box|).(Script_typed_ir.Boxed_set.size).
    
    Definition set_update {A B : Set}
      (key : A) (_presence : B) (set : Script_typed_ir.set A)
      : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_starat (set_access key set)
        (Alpha_context.Gas.alloc_cost 3).
  End Legacy.
  
  Module Interpreter.
    Definition cycle : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition nop : Alpha_context.Gas.cost := Alpha_context.Gas.free.
    
    Definition stack_op : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition push : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition wrap : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition variant_no_data : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition branch : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition pair : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition pair_access : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition cons : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition loop_size : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 5.
    
    Definition loop_cycle : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition loop_iter : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 20.
    
    Definition loop_map : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 30.
    
    Definition empty_set : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition set_to_list {elt : Set} (Box : Script_typed_ir.set elt)
      : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_star (|Box|).(Script_typed_ir.Boxed_set.size) 20).
    
    Definition set_mem {elt : Set} (elt : elt) (Box : Script_typed_ir.set elt)
      : Alpha_context.Gas.cost :=
      let elt_bytes :=
        size_of_comparable (|Box|).(Script_typed_ir.Boxed_set.elt_ty) elt in
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_star
          (Pervasives.op_plus 1 (Pervasives.op_div elt_bytes 82))
          (log2 (|Box|).(Script_typed_ir.Boxed_set.size))).
    
    Definition set_update {elt : Set} (elt : elt) (function_parameter : bool)
      : Script_typed_ir.set elt -> Alpha_context.Gas.cost :=
      let '_ := function_parameter in
      fun Box =>
        let elt_bytes :=
          size_of_comparable (|Box|).(Script_typed_ir.Boxed_set.elt_ty) elt in
        Alpha_context.Gas.atomic_step_cost
          (Pervasives.op_star
            (Pervasives.op_plus 1 (Pervasives.op_div elt_bytes 82))
            (log2 (|Box|).(Script_typed_ir.Boxed_set.size))).
    
    Definition set_size : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition empty_map : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition map_to_list {key value : Set}
      (Box : Script_typed_ir.map key value) : Alpha_context.Gas.cost :=
      let size := Pervasives.snd (|Box|).(Script_typed_ir.Boxed_map.boxed) in
      Alpha_context.Gas.atomic_step_cost (Pervasives.op_star size 20).
    
    Definition map_access {key value : Set}
      (key : key) (Box : Script_typed_ir.map key value)
      : Alpha_context.Gas.cost :=
      let map_card := Pervasives.snd (|Box|).(Script_typed_ir.Boxed_map.boxed)
        in
      let key_bytes :=
        size_of_comparable (|Box|).(Script_typed_ir.Boxed_map.key_ty) key in
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_star
          (Pervasives.op_plus 1 (Pervasives.op_div key_bytes 70))
          (log2 map_card)).
    
    Definition map_mem {A B : Set}
      : A -> Script_typed_ir.map A B -> Alpha_context.Gas.cost := map_access.
    
    Definition map_get {A B : Set}
      : A -> Script_typed_ir.map A B -> Alpha_context.Gas.cost := map_access.
    
    Definition map_update {key value : Set}
      (key : key) (_value : option value) (Box : Script_typed_ir.map key value)
      : Alpha_context.Gas.cost :=
      let map_card := Pervasives.snd (|Box|).(Script_typed_ir.Boxed_map.boxed)
        in
      let key_bytes :=
        size_of_comparable (|Box|).(Script_typed_ir.Boxed_map.key_ty) key in
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_star
          (Pervasives.op_plus 1 (Pervasives.op_div key_bytes 38))
          (log2 map_card)).
    
    Definition map_size : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition add_timestamp {a : Set}
      (t1 : Alpha_context.Script_timestamp.t)
      (t2 : Alpha_context.Script_int.num a) : Alpha_context.Gas.cost :=
      let bytes1 := timestamp_bytes t1 in
      let bytes2 := int_bytes t2 in
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 51
          (Pervasives.op_div ((|Compare.Int|).(Compare.S.max) bytes1 bytes2) 62)).
    
    Definition sub_timestamp {A : Set}
      : Alpha_context.Script_timestamp.t -> Alpha_context.Script_int.num A ->
      Alpha_context.Gas.cost := add_timestamp.
    
    Definition diff_timestamps
      (t1 : Alpha_context.Script_timestamp.t)
      (t2 : Alpha_context.Script_timestamp.t) : Alpha_context.Gas.cost :=
      let bytes1 := timestamp_bytes t1 in
      let bytes2 := timestamp_bytes t2 in
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 51
          (Pervasives.op_div ((|Compare.Int|).(Compare.S.max) bytes1 bytes2) 62)).
    
    Fixpoint concat_loop {A : Set} (l : list A) (acc : Z) {struct l} : Z :=
      match l with
      | [] => 30
      | cons _ tl => concat_loop tl (Pervasives.op_plus acc 30)
      end.
    
    Definition concat_string {A : Set} (string_list : list A)
      : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost (concat_loop string_list 0).
    
    Definition slice_string (string_length : Z) : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 40 (Pervasives.op_div string_length 70)).
    
    Definition concat_bytes {A : Set} (bytes_list : list A)
      : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost (concat_loop bytes_list 0).
    
    Definition int64_op : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 61.
    
    Definition z_to_int64 : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 20.
    
    Definition int64_to_z : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 20.
    
    Definition bool_binop {A B : Set} (function_parameter : A)
      : B -> Alpha_context.Gas.cost :=
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        Alpha_context.Gas.atomic_step_cost 10.
    
    Definition bool_unop {A : Set} (function_parameter : A)
      : Alpha_context.Gas.cost :=
      let '_ := function_parameter in
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition abs {A : Set} (int : Alpha_context.Script_int.num A)
      : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 61 (Pervasives.op_div (int_bytes Z) 70)).
    
    Definition int {A : Set} (_int : A) : Alpha_context.Gas.cost :=
      Alpha_context.Gas.free.
    
    Definition neg {A : Set}
      : Alpha_context.Script_int.num A -> Alpha_context.Gas.cost := abs.
    
    Definition add {A B : Set}
      (i1 : Alpha_context.Script_int.num A)
      (i2 : Alpha_context.Script_int.num B) : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 51
          (Pervasives.op_div
            ((|Compare.Int|).(Compare.S.max) (int_bytes i1) (int_bytes i2)) 62)).
    
    Definition sub {A B : Set}
      : Alpha_context.Script_int.num A -> Alpha_context.Script_int.num B ->
      Alpha_context.Gas.cost := add.
    
    Definition mul {A B : Set}
      (i1 : Alpha_context.Script_int.num A)
      (i2 : Alpha_context.Script_int.num B) : Alpha_context.Gas.cost :=
      let __bytes_value :=
        (|Compare.Int|).(Compare.S.max) (int_bytes i1) (int_bytes i2) in
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 51
          (Pervasives.op_star (Pervasives.op_div __bytes_value 6)
            (log2 __bytes_value))).
    
    Definition indic_lt
      (x : (|Compare.Int|).(Compare.S.t)) (y : (|Compare.Int|).(Compare.S.t))
      : Z :=
      if (|Compare.Int|).(Compare.S.op_lt) x y then
        1
      else
        0.
    
    Definition div {A B : Set}
      (i1 : Alpha_context.Script_int.num A)
      (i2 : Alpha_context.Script_int.num B) : Alpha_context.Gas.cost :=
      let bytes1 := int_bytes i1 in
      let bytes2 := int_bytes i2 in
      let cost :=
        Pervasives.op_star
          (Pervasives.op_star (indic_lt bytes2 bytes1)
            (Pervasives.op_minus bytes1 bytes2)) bytes2 in
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 51 (Pervasives.op_div cost 3151)).
    
    Definition shift_left {A B : Set} (_i : A) (_shift_bits : B)
      : Alpha_context.Gas.cost := Alpha_context.Gas.atomic_step_cost 30.
    
    Definition shift_right {A B : Set} (_i : A) (_shift_bits : B)
      : Alpha_context.Gas.cost := Alpha_context.Gas.atomic_step_cost 30.
    
    Definition logor {A B : Set}
      (i1 : Alpha_context.Script_int.num A)
      (i2 : Alpha_context.Script_int.num B) : Alpha_context.Gas.cost :=
      let bytes1 := int_bytes i1 in
      let bytes2 := int_bytes i2 in
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 51
          (Pervasives.op_div ((|Compare.Int|).(Compare.S.max) bytes1 bytes2) 70)).
    
    Definition logand {A B : Set}
      (i1 : Alpha_context.Script_int.num A)
      (i2 : Alpha_context.Script_int.num B) : Alpha_context.Gas.cost :=
      let bytes1 := int_bytes i1 in
      let bytes2 := int_bytes i2 in
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 51
          (Pervasives.op_div ((|Compare.Int|).(Compare.S.min) bytes1 bytes2) 70)).
    
    Definition logxor {A B : Set}
      : Alpha_context.Script_int.num A -> Alpha_context.Script_int.num B ->
      Alpha_context.Gas.cost := logor.
    
    Definition lognot {A : Set} (i : Alpha_context.Script_int.num A)
      : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 51 (Pervasives.op_div (int_bytes i) 20)).
    
    Definition exec : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition compare_bool {A B : Set} (function_parameter : A)
      : B -> Alpha_context.Gas.cost :=
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        Alpha_context.Gas.atomic_step_cost 30.
    
    Definition compare_string (s1 : string) (s2 : string)
      : Alpha_context.Gas.cost :=
      let bytes1 := String.length s1 in
      let bytes2 := String.length s2 in
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 30
          (Pervasives.op_div ((|Compare.Int|).(Compare.S.min) bytes1 bytes2) 123)).
    
    Definition compare_bytes (b1 : MBytes.t) (b2 : MBytes.t)
      : Alpha_context.Gas.cost :=
      let bytes1 := MBytes.length b1 in
      let bytes2 := MBytes.length b2 in
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 30
          (Pervasives.op_div ((|Compare.Int|).(Compare.S.min) bytes1 bytes2) 123)).
    
    Definition compare_tez {A B : Set} (function_parameter : A)
      : B -> Alpha_context.Gas.cost :=
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        Alpha_context.Gas.atomic_step_cost 30.
    
    Definition compare_zint {A B : Set}
      (i1 : Alpha_context.Script_int.num A)
      (i2 : Alpha_context.Script_int.num B) : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 51
          (Pervasives.op_div
            ((|Compare.Int|).(Compare.S.min) (int_bytes i1) (int_bytes i2)) 82)).
    
    Definition compare_key_hash {A B : Set} (function_parameter : A)
      : B -> Alpha_context.Gas.cost :=
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        Alpha_context.Gas.atomic_step_cost 92.
    
    Definition compare_timestamp
      (t1 : Alpha_context.Script_timestamp.t)
      (t2 : Alpha_context.Script_timestamp.t) : Alpha_context.Gas.cost :=
      let bytes1 := timestamp_bytes t1 in
      let bytes2 := timestamp_bytes t2 in
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 51
          (Pervasives.op_div ((|Compare.Int|).(Compare.S.min) bytes1 bytes2) 82)).
    
    Definition compare_address {A B : Set} (function_parameter : A)
      : B -> Alpha_context.Gas.cost :=
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        Alpha_context.Gas.atomic_step_cost 92.
    
    Definition compare_res : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 30.
    
    Definition unpack_failed (__bytes_value : MBytes.t)
      : Alpha_context.Gas.cost :=
      let len := MBytes.length __bytes_value in
      Alpha_context.Gas.op_plusat
        (Alpha_context.Gas.op_starat len (Alpha_context.Gas.alloc_mbytes_cost 1))
        (Alpha_context.Gas.op_starat len
          (Alpha_context.Gas.op_starat (log2 len)
            (Alpha_context.Gas.op_plusat (Alpha_context.Gas.alloc_cost 3)
              (Alpha_context.Gas.step_cost 1)))).
    
    Definition address : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition contract : Alpha_context.Gas.cost :=
      Alpha_context.Gas.step_cost 10000.
    
    Definition transfer : Alpha_context.Gas.cost :=
      Alpha_context.Gas.step_cost 10.
    
    Definition create_account : Alpha_context.Gas.cost :=
      Alpha_context.Gas.step_cost 10.
    
    Definition create_contract : Alpha_context.Gas.cost :=
      Alpha_context.Gas.step_cost 10.
    
    Definition implicit_account : Alpha_context.Gas.cost :=
      Alpha_context.Gas.step_cost 10.
    
    Definition set_delegate : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_plusat (Alpha_context.Gas.step_cost 10)
        (Alpha_context.Gas.write_bytes_cost (Z.of_int 32)).
    
    Definition balance : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition now : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition check_signature_secp256k1 (__bytes_value : Z)
      : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 10342 (Pervasives.op_div __bytes_value 5)).
    
    Definition check_signature_ed25519 (__bytes_value : Z)
      : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 36864 (Pervasives.op_div __bytes_value 5)).
    
    Definition check_signature_p256 (__bytes_value : Z)
      : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 36864 (Pervasives.op_div __bytes_value 5)).
    
    Definition check_signature
      (pkey : Signature.public_key) (__bytes_value : MBytes.t)
      : Alpha_context.Gas.cost :=
      match pkey with
      | Signature.Ed25519 _ =>
        check_signature_ed25519 (MBytes.length __bytes_value)
      | Signature.Secp256k1 _ =>
        check_signature_secp256k1 (MBytes.length __bytes_value)
      | Signature.P256 _ => check_signature_p256 (MBytes.length __bytes_value)
      end.
    
    Definition hash_key : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 30.
    
    Definition hash_blake2b (b : MBytes.t) : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 102 (Pervasives.op_div (MBytes.length b) 5)).
    
    Definition hash_sha256 (b : MBytes.t) : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 409 (MBytes.length b)).
    
    Definition hash_sha512 (b : MBytes.t) : Alpha_context.Gas.cost :=
      let __bytes_value := MBytes.length b in
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 409
          (Pervasives.op_plus (Pervasives.lsr __bytes_value 1)
            (Pervasives.lsr __bytes_value 4))).
    
    Definition steps_to_quota : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition source : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition self : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition amount : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost 10.
    
    Definition chain_id : Alpha_context.Gas.cost :=
      Alpha_context.Gas.step_cost 1.
    
    Definition stack_n_op (n : Z) : Alpha_context.Gas.cost :=
      Alpha_context.Gas.atomic_step_cost
        (Pervasives.op_plus 20
          (Pervasives.op_plus
            (Pervasives.op_plus (Pervasives.lsr n 1) (Pervasives.lsr n 2))
            (Pervasives.lsr n 4))).
    
    Definition apply : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_plusat (Alpha_context.Gas.alloc_cost 8)
        (Alpha_context.Gas.step_cost 1).
    
    Fixpoint compare {a s : Set}
      (ty : Script_typed_ir.comparable_struct a s) (x : a) (y : a) {struct ty}
      : Alpha_context.Gas.cost :=
      match ty with
      | Script_typed_ir.Bool_key _ => compare_bool x y
      | Script_typed_ir.String_key _ => compare_string x y
      | Script_typed_ir.Bytes_key _ => compare_bytes x y
      | Script_typed_ir.Mutez_key _ => compare_tez x y
      | Script_typed_ir.Int_key _ => compare_zint x y
      | Script_typed_ir.Nat_key _ => compare_zint x y
      | Script_typed_ir.Key_hash_key _ => compare_key_hash x y
      | Script_typed_ir.Timestamp_key _ => compare_timestamp x y
      | Script_typed_ir.Address_key _ => compare_address x y
      | Script_typed_ir.Pair_key (tl, _) (tr, _) _ =>
        in
        Alpha_context.Gas.op_plusat (compare tl xl yl) (compare tr xr yr)
      end.
  End Interpreter.
  
  Module Typechecking.
    Definition cycle : Alpha_context.Gas.cost := Alpha_context.Gas.step_cost 1.
    
    Definition __bool_value : Alpha_context.Gas.cost := Alpha_context.Gas.free.
    
    Definition __unit_value : Alpha_context.Gas.cost := Alpha_context.Gas.free.
    
    Definition __string_value : Z -> Alpha_context.Gas.cost := __string_value.
    
    Definition __bytes_value : Z -> Alpha_context.Gas.cost := __bytes_value.
    
    Definition z : Z.t -> Alpha_context.Gas.cost := Legacy.zint.
    
    Definition int_of_string (str : string) : Alpha_context.Gas.cost :=
      Pervasives.op_atat Alpha_context.Gas.alloc_cost
        (Pervasives.op_div (String.length str) 5).
    
    Definition tez : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_plusat (Alpha_context.Gas.step_cost 1)
        (Alpha_context.Gas.alloc_cost 1).
    
    Definition string_timestamp : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_plusat (Alpha_context.Gas.step_cost 3)
        (Alpha_context.Gas.alloc_cost 3).
    
    Definition key : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_plusat (Alpha_context.Gas.step_cost 3)
        (Alpha_context.Gas.alloc_cost 3).
    
    Definition key_hash : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_plusat (Alpha_context.Gas.step_cost 1)
        (Alpha_context.Gas.alloc_cost 1).
    
    Definition signature : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_plusat (Alpha_context.Gas.step_cost 1)
        (Alpha_context.Gas.alloc_cost 1).
    
    Definition chain_id : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_plusat (Alpha_context.Gas.step_cost 1)
        (Alpha_context.Gas.alloc_cost 1).
    
    Definition contract : Alpha_context.Gas.cost :=
      Alpha_context.Gas.step_cost 5.
    
    Definition get_script : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_plusat (Alpha_context.Gas.step_cost 20)
        (Alpha_context.Gas.alloc_cost 5).
    
    Definition contract_exists : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_plusat (Alpha_context.Gas.step_cost 15)
        (Alpha_context.Gas.alloc_cost 5).
    
    Definition pair : Alpha_context.Gas.cost := Alpha_context.Gas.alloc_cost 2.
    
    Definition union : Alpha_context.Gas.cost := Alpha_context.Gas.alloc_cost 1.
    
    Definition lambda : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_plusat (Alpha_context.Gas.alloc_cost 5)
        (Alpha_context.Gas.step_cost 3).
    
    Definition some : Alpha_context.Gas.cost := Alpha_context.Gas.alloc_cost 1.
    
    Definition none : Alpha_context.Gas.cost := Alpha_context.Gas.alloc_cost 0.
    
    Definition list_element : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_plusat (Alpha_context.Gas.alloc_cost 2)
        (Alpha_context.Gas.step_cost 1).
    
    Definition set_element (size : Z) : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_starat (log2 size)
        (Alpha_context.Gas.op_plusat (Alpha_context.Gas.alloc_cost 3)
          (Alpha_context.Gas.step_cost 2)).
    
    Definition map_element (size : Z) : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_starat (log2 size)
        (Alpha_context.Gas.op_plusat (Alpha_context.Gas.alloc_cost 4)
          (Alpha_context.Gas.step_cost 2)).
    
    Definition primitive_type : Alpha_context.Gas.cost :=
      Alpha_context.Gas.alloc_cost 1.
    
    Definition one_arg_type : Alpha_context.Gas.cost :=
      Alpha_context.Gas.alloc_cost 2.
    
    Definition two_arg_type : Alpha_context.Gas.cost :=
      Alpha_context.Gas.alloc_cost 3.
    
    Definition operation (b : Z) : Alpha_context.Gas.cost := __bytes_value b.
    
    Definition type_ (nb_args : Z) : Alpha_context.Gas.cost :=
      Alpha_context.Gas.alloc_cost (Pervasives.op_plus nb_args 1).
    
    Definition instr {a b : Set} (i : Script_typed_ir.instr b a)
      : Alpha_context.Gas.cost :=
      Alpha_context.Gas.op_plusat (Alpha_context.Gas.alloc_cost 1)
        match i with
        | Script_typed_ir.Drop => Alpha_context.Gas.alloc_cost 0
        | Script_typed_ir.Dup => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Swap => Alpha_context.Gas.alloc_cost 0
        | Script_typed_ir.Const _ => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Cons_pair => Alpha_context.Gas.alloc_cost 2
        | Script_typed_ir.Car => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Cdr => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Cons_some => Alpha_context.Gas.alloc_cost 2
        | Script_typed_ir.Cons_none _ => Alpha_context.Gas.alloc_cost 3
        | Script_typed_ir.If_none _ _ => Alpha_context.Gas.alloc_cost 2
        | Script_typed_ir.Left => Alpha_context.Gas.alloc_cost 3
        | Script_typed_ir.Right => Alpha_context.Gas.alloc_cost 3
        | Script_typed_ir.If_left _ _ => Alpha_context.Gas.alloc_cost 2
        | Script_typed_ir.Cons_list => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Nil => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.If_cons _ _ => Alpha_context.Gas.alloc_cost 2
        | Script_typed_ir.List_map _ => Alpha_context.Gas.alloc_cost 5
        | Script_typed_ir.List_iter _ => Alpha_context.Gas.alloc_cost 4
        | Script_typed_ir.List_size => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Empty_set _ => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Set_iter _ => Alpha_context.Gas.alloc_cost 4
        | Script_typed_ir.Set_mem => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Set_update => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Set_size => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Empty_map _ _ => Alpha_context.Gas.alloc_cost 2
        | Script_typed_ir.Map_map _ => Alpha_context.Gas.alloc_cost 5
        | Script_typed_ir.Map_iter _ => Alpha_context.Gas.alloc_cost 4
        | Script_typed_ir.Map_mem => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Map_get => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Map_update => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Map_size => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Empty_big_map _ _ => Alpha_context.Gas.alloc_cost 2
        | Script_typed_ir.Big_map_mem => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Big_map_get => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Big_map_update => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Concat_string => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Concat_string_pair => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Concat_bytes => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Concat_bytes_pair => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Slice_string => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Slice_bytes => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.String_size => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Bytes_size => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Add_seconds_to_timestamp =>
          Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Add_timestamp_to_seconds =>
          Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Sub_timestamp_seconds =>
          Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Diff_timestamps => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Add_tez => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Sub_tez => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Mul_teznat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Mul_nattez => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Ediv_teznat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Ediv_tez => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Or => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.And => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Xor => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Not => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Is_nat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Neg_nat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Neg_int => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Abs_int => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Int_nat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Add_intint => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Add_intnat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Add_natint => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Add_natnat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Sub_int => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Mul_intint => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Mul_intnat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Mul_natint => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Mul_natnat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Ediv_intint => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Ediv_intnat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Ediv_natint => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Ediv_natnat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Lsl_nat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Lsr_nat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Or_nat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.And_nat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.And_int_nat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Xor_nat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Not_nat => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Not_int => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Seq _ _ => Alpha_context.Gas.alloc_cost 8
        | Script_typed_ir.If _ _ => Alpha_context.Gas.alloc_cost 8
        | Script_typed_ir.Loop _ => Alpha_context.Gas.alloc_cost 4
        | Script_typed_ir.Loop_left _ => Alpha_context.Gas.alloc_cost 5
        | Script_typed_ir.Dip _ => Alpha_context.Gas.alloc_cost 4
        | Script_typed_ir.Exec => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Apply _ => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Lambda _ => Alpha_context.Gas.alloc_cost 2
        | Script_typed_ir.Failwith _ => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Nop => Alpha_context.Gas.alloc_cost 0
        | Script_typed_ir.Compare _ => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Eq => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Neq => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Lt => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Gt => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Le => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Ge => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Address => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Contract _ _ => Alpha_context.Gas.alloc_cost 2
        | Script_typed_ir.Transfer_tokens => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Create_account => Alpha_context.Gas.alloc_cost 2
        | Script_typed_ir.Implicit_account => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Create_contract _ _ _ _ =>
          Alpha_context.Gas.alloc_cost 8
        | Script_typed_ir.Create_contract_2 _ _ _ _ =>
          Alpha_context.Gas.alloc_cost 7
        | Script_typed_ir.Set_delegate => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Now => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Balance => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Check_signature => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Hash_key => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Pack _ => Alpha_context.Gas.alloc_cost 2
        | Script_typed_ir.Unpack _ => Alpha_context.Gas.alloc_cost 2
        | Script_typed_ir.Blake2b => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Sha256 => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Sha512 => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Steps_to_quota => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Source => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Sender => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Self _ _ => Alpha_context.Gas.alloc_cost 2
        | Script_typed_ir.Amount => Alpha_context.Gas.alloc_cost 1
        | Script_typed_ir.Dig n _ =>
          Alpha_context.Gas.op_starat n (Alpha_context.Gas.alloc_cost 1)
        | Script_typed_ir.Dug n _ =>
          Alpha_context.Gas.op_starat n (Alpha_context.Gas.alloc_cost 1)
        | Script_typed_ir.Dipn n _ _ =>
          Alpha_context.Gas.op_starat n (Alpha_context.Gas.alloc_cost 1)
        | Script_typed_ir.Dropn n _ =>
          Alpha_context.Gas.op_starat n (Alpha_context.Gas.alloc_cost 1)
        | Script_typed_ir.ChainId => Alpha_context.Gas.alloc_cost 1
        end.
  End Typechecking.
  
  Module Unparse.
    Definition prim_cost (l : Z) (annot : Alpha_context.Script.annot)
      : Alpha_context.Gas.cost :=
      Alpha_context.Script.prim_node_cost_nonrec_of_length l annot.
    
    Definition seq_cost : Z -> Alpha_context.Gas.cost :=
      Alpha_context.Script.seq_node_cost_nonrec_of_length.
    
    Definition string_cost (length : Z) : Alpha_context.Gas.cost :=
      Alpha_context.Script.string_node_cost_of_length length.
    
    Definition cycle : Alpha_context.Gas.cost := Alpha_context.Gas.step_cost 1.
    
    Definition __bool_value : Alpha_context.Gas.cost := prim_cost 0 [].
    
    Definition __unit_value : Alpha_context.Gas.cost := prim_cost 0 [].
    
    Definition __string_value (s : string) : Alpha_context.Gas.cost :=
      Alpha_context.Script.string_node_cost s.
    
    Definition __bytes_value (s : MBytes.t) : Alpha_context.Gas.cost :=
      Alpha_context.Script.bytes_node_cost s.
    
    Definition z (i : Z.t) : Alpha_context.Gas.cost :=
      Alpha_context.Script.int_node_cost i.
    
    Definition int {A : Set} (i : Alpha_context.Script_int.num A)
      : Alpha_context.Gas.cost :=
      Alpha_context.Script.int_node_cost (Alpha_context.Script_int.to_zint i).
    
    Definition tez : Alpha_context.Gas.cost :=
      Alpha_context.Script.int_node_cost_of_numbits 60.
    
    Definition timestamp (x : Alpha_context.Script_timestamp.t)
      : Alpha_context.Gas.cost :=
      Pervasives.op_pipegt
        (Pervasives.op_pipegt (Alpha_context.Script_timestamp.to_zint x)
          Alpha_context.Script_int.of_zint) Z.
    
    Definition operation (__bytes_value : MBytes.t) : Alpha_context.Gas.cost :=
      Alpha_context.Script.bytes_node_cost __bytes_value.
    
    Definition chain_id (__bytes_value : MBytes.t) : Alpha_context.Gas.cost :=
      Alpha_context.Script.bytes_node_cost __bytes_value.
    
    Definition key : Alpha_context.Gas.cost := string_cost 54.
    
    Definition key_hash : Alpha_context.Gas.cost := string_cost 36.
    
    Definition signature : Alpha_context.Gas.cost := string_cost 128.
    
    Definition contract : Alpha_context.Gas.cost := string_cost 36.
    
    Definition pair : Alpha_context.Gas.cost := prim_cost 2 [].
    
    Definition union : Alpha_context.Gas.cost := prim_cost 1 [].
    
    Definition some : Alpha_context.Gas.cost := prim_cost 1 [].
    
    Definition none : Alpha_context.Gas.cost := prim_cost 0 [].
    
    Definition list_element : Alpha_context.Gas.cost :=
      Alpha_context.Gas.alloc_cost 2.
    
    Definition set_element : Alpha_context.Gas.cost :=
      Alpha_context.Gas.alloc_cost 2.
    
    Definition map_element : Alpha_context.Gas.cost :=
      Alpha_context.Gas.alloc_cost 2.
    
    Definition one_arg_type
      : Alpha_context.Script.annot -> Alpha_context.Gas.cost := prim_cost 1.
    
    Definition two_arg_type
      : Alpha_context.Script.annot -> Alpha_context.Gas.cost := prim_cost 2.
    
    Definition set_to_list {A : Set}
      : Script_typed_ir.set A -> Alpha_context.Gas.cost := Legacy.set_to_list.
    
    Definition map_to_list {A B : Set}
      : Script_typed_ir.map A B -> Alpha_context.Gas.cost := Legacy.map_to_list.
  End Unparse.
End Cost_of.

Michelson_v1_gas_mli

  • OCaml size: 316 lines
  • Coq size: 344 lines (+8% compared to OCaml)
michelson_v1_gas.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

module Cost_of : sig
  val manager_operation : Gas.cost

  module Legacy : sig
    val z_to_int64 : Gas.cost

    val hash : MBytes.t -> int -> Gas.cost

    val map_to_list : ('b, 'c) Script_typed_ir.map -> Gas.cost

    val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost
  end

  module Interpreter : sig
    val cycle : Gas.cost

    val loop_cycle : Gas.cost

    val loop_size : Gas.cost

    val loop_iter : Gas.cost

    val loop_map : Gas.cost

    val nop : Gas.cost

    val stack_op : Gas.cost

    val stack_n_op : int -> Gas.cost

    val bool_binop : 'a -> 'b -> Gas.cost

    val bool_unop : 'a -> Gas.cost

    val pair : Gas.cost

    val pair_access : Gas.cost

    val cons : Gas.cost

    val variant_no_data : Gas.cost

    val branch : Gas.cost

    val concat_string : string list -> Gas.cost

    val concat_bytes : MBytes.t list -> Gas.cost

    val slice_string : int -> Gas.cost

    val map_mem : 'a -> ('a, 'b) Script_typed_ir.map -> Gas.cost

    val map_to_list : ('a, 'b) Script_typed_ir.map -> Gas.cost

    val map_get : 'a -> ('a, 'b) Script_typed_ir.map -> Gas.cost

    val map_update :
      'a -> 'b option -> ('a, 'b) Script_typed_ir.map -> Gas.cost

    val map_size : Gas.cost

    val set_to_list : 'a Script_typed_ir.set -> Gas.cost

    val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost

    val set_mem : 'a -> 'a Script_typed_ir.set -> Gas.cost

    val mul : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val div : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val add : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val sub : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val abs : 'a Script_int.num -> Gas.cost

    val neg : 'a Script_int.num -> Gas.cost

    val int : 'a -> Gas.cost

    val add_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost

    val sub_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost

    val diff_timestamps : Script_timestamp.t -> Script_timestamp.t -> Gas.cost

    val empty_set : Gas.cost

    val set_size : Gas.cost

    val empty_map : Gas.cost

    val int64_op : Gas.cost

    val z_to_int64 : Gas.cost

    val int64_to_z : Gas.cost

    val logor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val logand : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val logxor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val lognot : 'a Script_int.num -> Gas.cost

    val shift_left : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val shift_right : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val exec : Gas.cost

    val push : Gas.cost

    val compare_res : Gas.cost

    val unpack_failed : MBytes.t -> Gas.cost

    val address : Gas.cost

    val contract : Gas.cost

    val transfer : Gas.cost

    val create_account : Gas.cost

    val create_contract : Gas.cost

    val implicit_account : Gas.cost

    val set_delegate : Gas.cost

    val balance : Gas.cost

    val now : Gas.cost

    val check_signature : public_key -> MBytes.t -> Gas.cost

    val hash_key : Gas.cost

    val hash_blake2b : MBytes.t -> Gas.cost

    val hash_sha256 : MBytes.t -> Gas.cost

    val hash_sha512 : MBytes.t -> Gas.cost

    val steps_to_quota : Gas.cost

    val source : Gas.cost

    val self : Gas.cost

    val amount : Gas.cost

    val chain_id : Gas.cost

    val wrap : Gas.cost

    val compare : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> Gas.cost

    val apply : Gas.cost
  end

  module Typechecking : sig
    val cycle : Gas.cost

    val unit : Gas.cost

    val bool : Gas.cost

    val tez : Gas.cost

    val z : Z.t -> Gas.cost

    val string : int -> Gas.cost

    val bytes : int -> Gas.cost

    val int_of_string : string -> Gas.cost

    val string_timestamp : Gas.cost

    val key : Gas.cost

    val key_hash : Gas.cost

    val signature : Gas.cost

    val chain_id : Gas.cost

    val contract : Gas.cost

    (** Gas.Cost of getting the code for a contract *)
    val get_script : Gas.cost

    val contract_exists : Gas.cost

    (** Additional Gas.cost of parsing a pair over the Gas.cost of parsing each type  *)
    val pair : Gas.cost

    val union : Gas.cost

    val lambda : Gas.cost

    val some : Gas.cost

    val none : Gas.cost

    val list_element : Gas.cost

    val set_element : int -> Gas.cost

    val map_element : int -> Gas.cost

    val primitive_type : Gas.cost

    val one_arg_type : Gas.cost

    val two_arg_type : Gas.cost

    val operation : int -> Gas.cost

    (** Cost of parsing a type *)
    val type_ : int -> Gas.cost

    (** Cost of parsing an instruction *)
    val instr : ('a, 'b) Script_typed_ir.instr -> Gas.cost
  end

  module Unparse : sig
    val prim_cost : int -> Script.annot -> Gas.cost

    val seq_cost : int -> Gas.cost

    val cycle : Gas.cost

    val unit : Gas.cost

    val bool : Gas.cost

    val z : Z.t -> Gas.cost

    val int : 'a Script_int.num -> Gas.cost

    val tez : Gas.cost

    val string : string -> Gas.cost

    val bytes : MBytes.t -> Gas.cost

    val timestamp : Script_timestamp.t -> Gas.cost

    val key : Gas.cost

    val key_hash : Gas.cost

    val signature : Gas.cost

    val operation : MBytes.t -> Gas.cost

    val chain_id : MBytes.t -> Gas.cost

    val contract : Gas.cost

    (** Additional Gas.cost of parsing a pair over the Gas.cost of parsing each type  *)
    val pair : Gas.cost

    val union : Gas.cost

    val some : Gas.cost

    val none : Gas.cost

    val list_element : Gas.cost

    val set_element : Gas.cost

    val map_element : Gas.cost

    val one_arg_type : Script.annot -> Gas.cost

    val two_arg_type : Script.annot -> Gas.cost

    val set_to_list : 'a Script_typed_ir.set -> Gas.cost

    val map_to_list : ('a, 'b) Script_typed_ir.map -> Gas.cost
  end
end
Michelson_v1_gas_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Script_typed_ir.

Module Cost_of.
  Parameter manager_operation : Alpha_context.Gas.cost.
  
  Module Legacy.
    Parameter z_to_int64 : Alpha_context.Gas.cost.
    
    Parameter __hash_value : MBytes.t -> Z -> Alpha_context.Gas.cost.
    
    Parameter map_to_list : forall {b c : Set},
      Script_typed_ir.map b c -> Alpha_context.Gas.cost.
    
    Parameter set_update : forall {a : Set},
      a -> bool -> Script_typed_ir.set a -> Alpha_context.Gas.cost.
  End Legacy.
  
  Module Interpreter.
    Parameter cycle : Alpha_context.Gas.cost.
    
    Parameter loop_cycle : Alpha_context.Gas.cost.
    
    Parameter loop_size : Alpha_context.Gas.cost.
    
    Parameter loop_iter : Alpha_context.Gas.cost.
    
    Parameter loop_map : Alpha_context.Gas.cost.
    
    Parameter nop : Alpha_context.Gas.cost.
    
    Parameter stack_op : Alpha_context.Gas.cost.
    
    Parameter stack_n_op : Z -> Alpha_context.Gas.cost.
    
    Parameter bool_binop : forall {a b : Set}, a -> b -> Alpha_context.Gas.cost.
    
    Parameter bool_unop : forall {a : Set}, a -> Alpha_context.Gas.cost.
    
    Parameter pair : Alpha_context.Gas.cost.
    
    Parameter pair_access : Alpha_context.Gas.cost.
    
    Parameter cons : Alpha_context.Gas.cost.
    
    Parameter variant_no_data : Alpha_context.Gas.cost.
    
    Parameter branch : Alpha_context.Gas.cost.
    
    Parameter concat_string : list string -> Alpha_context.Gas.cost.
    
    Parameter concat_bytes : list MBytes.t -> Alpha_context.Gas.cost.
    
    Parameter slice_string : Z -> Alpha_context.Gas.cost.
    
    Parameter map_mem : forall {a b : Set},
      a -> Script_typed_ir.map a b -> Alpha_context.Gas.cost.
    
    Parameter map_to_list : forall {a b : Set},
      Script_typed_ir.map a b -> Alpha_context.Gas.cost.
    
    Parameter map_get : forall {a b : Set},
      a -> Script_typed_ir.map a b -> Alpha_context.Gas.cost.
    
    Parameter map_update : forall {a b : Set},
      a -> option b -> Script_typed_ir.map a b -> Alpha_context.Gas.cost.
    
    Parameter map_size : Alpha_context.Gas.cost.
    
    Parameter set_to_list : forall {a : Set},
      Script_typed_ir.set a -> Alpha_context.Gas.cost.
    
    Parameter set_update : forall {a : Set},
      a -> bool -> Script_typed_ir.set a -> Alpha_context.Gas.cost.
    
    Parameter set_mem : forall {a : Set},
      a -> Script_typed_ir.set a -> Alpha_context.Gas.cost.
    
    Parameter mul : forall {a b : Set},
      Alpha_context.Script_int.num a -> Alpha_context.Script_int.num b ->
      Alpha_context.Gas.cost.
    
    Parameter div : forall {a b : Set},
      Alpha_context.Script_int.num a -> Alpha_context.Script_int.num b ->
      Alpha_context.Gas.cost.
    
    Parameter add : forall {a b : Set},
      Alpha_context.Script_int.num a -> Alpha_context.Script_int.num b ->
      Alpha_context.Gas.cost.
    
    Parameter sub : forall {a b : Set},
      Alpha_context.Script_int.num a -> Alpha_context.Script_int.num b ->
      Alpha_context.Gas.cost.
    
    Parameter abs : forall {a : Set},
      Alpha_context.Script_int.num a -> Alpha_context.Gas.cost.
    
    Parameter neg : forall {a : Set},
      Alpha_context.Script_int.num a -> Alpha_context.Gas.cost.
    
    Parameter int : forall {a : Set}, a -> Alpha_context.Gas.cost.
    
    Parameter add_timestamp : forall {a : Set},
      Alpha_context.Script_timestamp.t -> Alpha_context.Script_int.num a ->
      Alpha_context.Gas.cost.
    
    Parameter sub_timestamp : forall {a : Set},
      Alpha_context.Script_timestamp.t -> Alpha_context.Script_int.num a ->
      Alpha_context.Gas.cost.
    
    Parameter diff_timestamps :
      Alpha_context.Script_timestamp.t -> Alpha_context.Script_timestamp.t ->
      Alpha_context.Gas.cost.
    
    Parameter empty_set : Alpha_context.Gas.cost.
    
    Parameter set_size : Alpha_context.Gas.cost.
    
    Parameter empty_map : Alpha_context.Gas.cost.
    
    Parameter int64_op : Alpha_context.Gas.cost.
    
    Parameter z_to_int64 : Alpha_context.Gas.cost.
    
    Parameter int64_to_z : Alpha_context.Gas.cost.
    
    Parameter logor : forall {a b : Set},
      Alpha_context.Script_int.num a -> Alpha_context.Script_int.num b ->
      Alpha_context.Gas.cost.
    
    Parameter logand : forall {a b : Set},
      Alpha_context.Script_int.num a -> Alpha_context.Script_int.num b ->
      Alpha_context.Gas.cost.
    
    Parameter logxor : forall {a b : Set},
      Alpha_context.Script_int.num a -> Alpha_context.Script_int.num b ->
      Alpha_context.Gas.cost.
    
    Parameter lognot : forall {a : Set},
      Alpha_context.Script_int.num a -> Alpha_context.Gas.cost.
    
    Parameter shift_left : forall {a b : Set},
      Alpha_context.Script_int.num a -> Alpha_context.Script_int.num b ->
      Alpha_context.Gas.cost.
    
    Parameter shift_right : forall {a b : Set},
      Alpha_context.Script_int.num a -> Alpha_context.Script_int.num b ->
      Alpha_context.Gas.cost.
    
    Parameter exec : Alpha_context.Gas.cost.
    
    Parameter push : Alpha_context.Gas.cost.
    
    Parameter compare_res : Alpha_context.Gas.cost.
    
    Parameter unpack_failed : MBytes.t -> Alpha_context.Gas.cost.
    
    Parameter address : Alpha_context.Gas.cost.
    
    Parameter contract : Alpha_context.Gas.cost.
    
    Parameter transfer : Alpha_context.Gas.cost.
    
    Parameter create_account : Alpha_context.Gas.cost.
    
    Parameter create_contract : Alpha_context.Gas.cost.
    
    Parameter implicit_account : Alpha_context.Gas.cost.
    
    Parameter set_delegate : Alpha_context.Gas.cost.
    
    Parameter balance : Alpha_context.Gas.cost.
    
    Parameter now : Alpha_context.Gas.cost.
    
    Parameter check_signature :
      Alpha_context.public_key -> MBytes.t -> Alpha_context.Gas.cost.
    
    Parameter hash_key : Alpha_context.Gas.cost.
    
    Parameter hash_blake2b : MBytes.t -> Alpha_context.Gas.cost.
    
    Parameter hash_sha256 : MBytes.t -> Alpha_context.Gas.cost.
    
    Parameter hash_sha512 : MBytes.t -> Alpha_context.Gas.cost.
    
    Parameter steps_to_quota : Alpha_context.Gas.cost.
    
    Parameter source : Alpha_context.Gas.cost.
    
    Parameter self : Alpha_context.Gas.cost.
    
    Parameter amount : Alpha_context.Gas.cost.
    
    Parameter chain_id : Alpha_context.Gas.cost.
    
    Parameter wrap : Alpha_context.Gas.cost.
    
    Parameter compare : forall {a : Set},
      Script_typed_ir.comparable_ty a -> a -> a -> Alpha_context.Gas.cost.
    
    Parameter apply : Alpha_context.Gas.cost.
  End Interpreter.
  
  Module Typechecking.
    Parameter cycle : Alpha_context.Gas.cost.
    
    Parameter __unit_value : Alpha_context.Gas.cost.
    
    Parameter __bool_value : Alpha_context.Gas.cost.
    
    Parameter tez : Alpha_context.Gas.cost.
    
    Parameter z : Z.t -> Alpha_context.Gas.cost.
    
    Parameter __string_value : Z -> Alpha_context.Gas.cost.
    
    Parameter __bytes_value : Z -> Alpha_context.Gas.cost.
    
    Parameter int_of_string : string -> Alpha_context.Gas.cost.
    
    Parameter string_timestamp : Alpha_context.Gas.cost.
    
    Parameter key : Alpha_context.Gas.cost.
    
    Parameter key_hash : Alpha_context.Gas.cost.
    
    Parameter signature : Alpha_context.Gas.cost.
    
    Parameter chain_id : Alpha_context.Gas.cost.
    
    Parameter contract : Alpha_context.Gas.cost.
    
    Parameter get_script : Alpha_context.Gas.cost.
    
    Parameter contract_exists : Alpha_context.Gas.cost.
    
    Parameter pair : Alpha_context.Gas.cost.
    
    Parameter union : Alpha_context.Gas.cost.
    
    Parameter lambda : Alpha_context.Gas.cost.
    
    Parameter some : Alpha_context.Gas.cost.
    
    Parameter none : Alpha_context.Gas.cost.
    
    Parameter list_element : Alpha_context.Gas.cost.
    
    Parameter set_element : Z -> Alpha_context.Gas.cost.
    
    Parameter map_element : Z -> Alpha_context.Gas.cost.
    
    Parameter primitive_type : Alpha_context.Gas.cost.
    
    Parameter one_arg_type : Alpha_context.Gas.cost.
    
    Parameter two_arg_type : Alpha_context.Gas.cost.
    
    Parameter operation : Z -> Alpha_context.Gas.cost.
    
    Parameter type_ : Z -> Alpha_context.Gas.cost.
    
    Parameter instr : forall {a b : Set},
      Script_typed_ir.instr a b -> Alpha_context.Gas.cost.
  End Typechecking.
  
  Module Unparse.
    Parameter prim_cost :
      Z -> Alpha_context.Script.annot -> Alpha_context.Gas.cost.
    
    Parameter seq_cost : Z -> Alpha_context.Gas.cost.
    
    Parameter cycle : Alpha_context.Gas.cost.
    
    Parameter __unit_value : Alpha_context.Gas.cost.
    
    Parameter __bool_value : Alpha_context.Gas.cost.
    
    Parameter z : Z.t -> Alpha_context.Gas.cost.
    
    Parameter int : forall {a : Set},
      Alpha_context.Script_int.num a -> Alpha_context.Gas.cost.
    
    Parameter tez : Alpha_context.Gas.cost.
    
    Parameter __string_value : string -> Alpha_context.Gas.cost.
    
    Parameter __bytes_value : MBytes.t -> Alpha_context.Gas.cost.
    
    Parameter timestamp :
      Alpha_context.Script_timestamp.t -> Alpha_context.Gas.cost.
    
    Parameter key : Alpha_context.Gas.cost.
    
    Parameter key_hash : Alpha_context.Gas.cost.
    
    Parameter signature : Alpha_context.Gas.cost.
    
    Parameter operation : MBytes.t -> Alpha_context.Gas.cost.
    
    Parameter chain_id : MBytes.t -> Alpha_context.Gas.cost.
    
    Parameter contract : Alpha_context.Gas.cost.
    
    Parameter pair : Alpha_context.Gas.cost.
    
    Parameter union : Alpha_context.Gas.cost.
    
    Parameter some : Alpha_context.Gas.cost.
    
    Parameter none : Alpha_context.Gas.cost.
    
    Parameter list_element : Alpha_context.Gas.cost.
    
    Parameter set_element : Alpha_context.Gas.cost.
    
    Parameter map_element : Alpha_context.Gas.cost.
    
    Parameter one_arg_type :
      Alpha_context.Script.annot -> Alpha_context.Gas.cost.
    
    Parameter two_arg_type :
      Alpha_context.Script.annot -> Alpha_context.Gas.cost.
    
    Parameter set_to_list : forall {a : Set},
      Script_typed_ir.set a -> Alpha_context.Gas.cost.
    
    Parameter map_to_list : forall {a b : Set},
      Script_typed_ir.map a b -> Alpha_context.Gas.cost.
  End Unparse.
End Cost_of.

Michelson_v1_primitives

  • OCaml size: 872 lines
  • Coq size: 624 lines (-29% compared to OCaml)
michelson_v1_primitives.ml 7 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Micheline

type error += Unknown_primitive_name of string

type error += Invalid_case of string

type error +=
  | Invalid_primitive_name of
      string Micheline.canonical * Micheline.canonical_location

type prim =
  | K_parameter
  | K_storage
  | K_code
  | D_False
  | D_Elt
  | D_Left
  | D_None
  | D_Pair
  | D_Right
  | D_Some
  | D_True
  | D_Unit
  | I_PACK
  | I_UNPACK
  | I_BLAKE2B
  | I_SHA256
  | I_SHA512
  | I_ABS
  | I_ADD
  | I_AMOUNT
  | I_AND
  | I_BALANCE
  | I_CAR
  | I_CDR
  | I_CHAIN_ID
  | I_CHECK_SIGNATURE
  | I_COMPARE
  | I_CONCAT
  | I_CONS
  | I_CREATE_ACCOUNT
  | I_CREATE_CONTRACT
  | I_IMPLICIT_ACCOUNT
  | I_DIP
  | I_DROP
  | I_DUP
  | I_EDIV
  | I_EMPTY_BIG_MAP
  | I_EMPTY_MAP
  | I_EMPTY_SET
  | I_EQ
  | I_EXEC
  | I_APPLY
  | I_FAILWITH
  | I_GE
  | I_GET
  | I_GT
  | I_HASH_KEY
  | I_IF
  | I_IF_CONS
  | I_IF_LEFT
  | I_IF_NONE
  | I_INT
  | I_LAMBDA
  | I_LE
  | I_LEFT
  | I_LOOP
  | I_LSL
  | I_LSR
  | I_LT
  | I_MAP
  | I_MEM
  | I_MUL
  | I_NEG
  | I_NEQ
  | I_NIL
  | I_NONE
  | I_NOT
  | I_NOW
  | I_OR
  | I_PAIR
  | I_PUSH
  | I_RIGHT
  | I_SIZE
  | I_SOME
  | I_SOURCE
  | I_SENDER
  | I_SELF
  | I_SLICE
  | I_STEPS_TO_QUOTA
  | I_SUB
  | I_SWAP
  | I_TRANSFER_TOKENS
  | I_SET_DELEGATE
  | I_UNIT
  | I_UPDATE
  | I_XOR
  | I_ITER
  | I_LOOP_LEFT
  | I_ADDRESS
  | I_CONTRACT
  | I_ISNAT
  | I_CAST
  | I_RENAME
  | I_DIG
  | I_DUG
  | T_bool
  | T_contract
  | T_int
  | T_key
  | T_key_hash
  | T_lambda
  | T_list
  | T_map
  | T_big_map
  | T_nat
  | T_option
  | T_or
  | T_pair
  | T_set
  | T_signature
  | T_string
  | T_bytes
  | T_mutez
  | T_timestamp
  | T_unit
  | T_operation
  | T_address
  | T_chain_id

let valid_case name =
  let is_lower = function '_' | 'a' .. 'z' -> true | _ -> false in
  let is_upper = function '_' | 'A' .. 'Z' -> true | _ -> false in
  let rec for_all a b f =
    Compare.Int.(a > b) || (f a && for_all (a + 1) b f)
  in
  let len = String.length name in
  Compare.Int.(len <> 0)
  && Compare.Char.(name.[0] <> '_')
  && ( (is_upper name.[0] && for_all 1 (len - 1) (fun i -> is_upper name.[i]))
     || (is_upper name.[0] && for_all 1 (len - 1) (fun i -> is_lower name.[i]))
     || (is_lower name.[0] && for_all 1 (len - 1) (fun i -> is_lower name.[i]))
     )

let string_of_prim = function
  | K_parameter ->
      "parameter"
  | K_storage ->
      "storage"
  | K_code ->
      "code"
  | D_False ->
      "False"
  | D_Elt ->
      "Elt"
  | D_Left ->
      "Left"
  | D_None ->
      "None"
  | D_Pair ->
      "Pair"
  | D_Right ->
      "Right"
  | D_Some ->
      "Some"
  | D_True ->
      "True"
  | D_Unit ->
      "Unit"
  | I_PACK ->
      "PACK"
  | I_UNPACK ->
      "UNPACK"
  | I_BLAKE2B ->
      "BLAKE2B"
  | I_SHA256 ->
      "SHA256"
  | I_SHA512 ->
      "SHA512"
  | I_ABS ->
      "ABS"
  | I_ADD ->
      "ADD"
  | I_AMOUNT ->
      "AMOUNT"
  | I_AND ->
      "AND"
  | I_BALANCE ->
      "BALANCE"
  | I_CAR ->
      "CAR"
  | I_CDR ->
      "CDR"
  | I_CHAIN_ID ->
      "CHAIN_ID"
  | I_CHECK_SIGNATURE ->
      "CHECK_SIGNATURE"
  | I_COMPARE ->
      "COMPARE"
  | I_CONCAT ->
      "CONCAT"
  | I_CONS ->
      "CONS"
  | I_CREATE_ACCOUNT ->
      "CREATE_ACCOUNT"
  | I_CREATE_CONTRACT ->
      "CREATE_CONTRACT"
  | I_IMPLICIT_ACCOUNT ->
      "IMPLICIT_ACCOUNT"
  | I_DIP ->
      "DIP"
  | I_DROP ->
      "DROP"
  | I_DUP ->
      "DUP"
  | I_EDIV ->
      "EDIV"
  | I_EMPTY_BIG_MAP ->
      "EMPTY_BIG_MAP"
  | I_EMPTY_MAP ->
      "EMPTY_MAP"
  | I_EMPTY_SET ->
      "EMPTY_SET"
  | I_EQ ->
      "EQ"
  | I_EXEC ->
      "EXEC"
  | I_APPLY ->
      "APPLY"
  | I_FAILWITH ->
      "FAILWITH"
  | I_GE ->
      "GE"
  | I_GET ->
      "GET"
  | I_GT ->
      "GT"
  | I_HASH_KEY ->
      "HASH_KEY"
  | I_IF ->
      "IF"
  | I_IF_CONS ->
      "IF_CONS"
  | I_IF_LEFT ->
      "IF_LEFT"
  | I_IF_NONE ->
      "IF_NONE"
  | I_INT ->
      "INT"
  | I_LAMBDA ->
      "LAMBDA"
  | I_LE ->
      "LE"
  | I_LEFT ->
      "LEFT"
  | I_LOOP ->
      "LOOP"
  | I_LSL ->
      "LSL"
  | I_LSR ->
      "LSR"
  | I_LT ->
      "LT"
  | I_MAP ->
      "MAP"
  | I_MEM ->
      "MEM"
  | I_MUL ->
      "MUL"
  | I_NEG ->
      "NEG"
  | I_NEQ ->
      "NEQ"
  | I_NIL ->
      "NIL"
  | I_NONE ->
      "NONE"
  | I_NOT ->
      "NOT"
  | I_NOW ->
      "NOW"
  | I_OR ->
      "OR"
  | I_PAIR ->
      "PAIR"
  | I_PUSH ->
      "PUSH"
  | I_RIGHT ->
      "RIGHT"
  | I_SIZE ->
      "SIZE"
  | I_SOME ->
      "SOME"
  | I_SOURCE ->
      "SOURCE"
  | I_SENDER ->
      "SENDER"
  | I_SELF ->
      "SELF"
  | I_SLICE ->
      "SLICE"
  | I_STEPS_TO_QUOTA ->
      "STEPS_TO_QUOTA"
  | I_SUB ->
      "SUB"
  | I_SWAP ->
      "SWAP"
  | I_TRANSFER_TOKENS ->
      "TRANSFER_TOKENS"
  | I_SET_DELEGATE ->
      "SET_DELEGATE"
  | I_UNIT ->
      "UNIT"
  | I_UPDATE ->
      "UPDATE"
  | I_XOR ->
      "XOR"
  | I_ITER ->
      "ITER"
  | I_LOOP_LEFT ->
      "LOOP_LEFT"
  | I_ADDRESS ->
      "ADDRESS"
  | I_CONTRACT ->
      "CONTRACT"
  | I_ISNAT ->
      "ISNAT"
  | I_CAST ->
      "CAST"
  | I_RENAME ->
      "RENAME"
  | I_DIG ->
      "DIG"
  | I_DUG ->
      "DUG"
  | T_bool ->
      "bool"
  | T_contract ->
      "contract"
  | T_int ->
      "int"
  | T_key ->
      "key"
  | T_key_hash ->
      "key_hash"
  | T_lambda ->
      "lambda"
  | T_list ->
      "list"
  | T_map ->
      "map"
  | T_big_map ->
      "big_map"
  | T_nat ->
      "nat"
  | T_option ->
      "option"
  | T_or ->
      "or"
  | T_pair ->
      "pair"
  | T_set ->
      "set"
  | T_signature ->
      "signature"
  | T_string ->
      "string"
  | T_bytes ->
      "bytes"
  | T_mutez ->
      "mutez"
  | T_timestamp ->
      "timestamp"
  | T_unit ->
      "unit"
  | T_operation ->
      "operation"
  | T_address ->
      "address"
  | T_chain_id ->
      "chain_id"

let prim_of_string = function
  | "parameter" ->
      ok K_parameter
  | "storage" ->
      ok K_storage
  | "code" ->
      ok K_code
  | "False" ->
      ok D_False
  | "Elt" ->
      ok D_Elt
  | "Left" ->
      ok D_Left
  | "None" ->
      ok D_None
  | "Pair" ->
      ok D_Pair
  | "Right" ->
      ok D_Right
  | "Some" ->
      ok D_Some
  | "True" ->
      ok D_True
  | "Unit" ->
      ok D_Unit
  | "PACK" ->
      ok I_PACK
  | "UNPACK" ->
      ok I_UNPACK
  | "BLAKE2B" ->
      ok I_BLAKE2B
  | "SHA256" ->
      ok I_SHA256
  | "SHA512" ->
      ok I_SHA512
  | "ABS" ->
      ok I_ABS
  | "ADD" ->
      ok I_ADD
  | "AMOUNT" ->
      ok I_AMOUNT
  | "AND" ->
      ok I_AND
  | "BALANCE" ->
      ok I_BALANCE
  | "CAR" ->
      ok I_CAR
  | "CDR" ->
      ok I_CDR
  | "CHAIN_ID" ->
      ok I_CHAIN_ID
  | "CHECK_SIGNATURE" ->
      ok I_CHECK_SIGNATURE
  | "COMPARE" ->
      ok I_COMPARE
  | "CONCAT" ->
      ok I_CONCAT
  | "CONS" ->
      ok I_CONS
  | "CREATE_ACCOUNT" ->
      ok I_CREATE_ACCOUNT
  | "CREATE_CONTRACT" ->
      ok I_CREATE_CONTRACT
  | "IMPLICIT_ACCOUNT" ->
      ok I_IMPLICIT_ACCOUNT
  | "DIP" ->
      ok I_DIP
  | "DROP" ->
      ok I_DROP
  | "DUP" ->
      ok I_DUP
  | "EDIV" ->
      ok I_EDIV
  | "EMPTY_BIG_MAP" ->
      ok I_EMPTY_BIG_MAP
  | "EMPTY_MAP" ->
      ok I_EMPTY_MAP
  | "EMPTY_SET" ->
      ok I_EMPTY_SET
  | "EQ" ->
      ok I_EQ
  | "EXEC" ->
      ok I_EXEC
  | "APPLY" ->
      ok I_APPLY
  | "FAILWITH" ->
      ok I_FAILWITH
  | "GE" ->
      ok I_GE
  | "GET" ->
      ok I_GET
  | "GT" ->
      ok I_GT
  | "HASH_KEY" ->
      ok I_HASH_KEY
  | "IF" ->
      ok I_IF
  | "IF_CONS" ->
      ok I_IF_CONS
  | "IF_LEFT" ->
      ok I_IF_LEFT
  | "IF_NONE" ->
      ok I_IF_NONE
  | "INT" ->
      ok I_INT
  | "LAMBDA" ->
      ok I_LAMBDA
  | "LE" ->
      ok I_LE
  | "LEFT" ->
      ok I_LEFT
  | "LOOP" ->
      ok I_LOOP
  | "LSL" ->
      ok I_LSL
  | "LSR" ->
      ok I_LSR
  | "LT" ->
      ok I_LT
  | "MAP" ->
      ok I_MAP
  | "MEM" ->
      ok I_MEM
  | "MUL" ->
      ok I_MUL
  | "NEG" ->
      ok I_NEG
  | "NEQ" ->
      ok I_NEQ
  | "NIL" ->
      ok I_NIL
  | "NONE" ->
      ok I_NONE
  | "NOT" ->
      ok I_NOT
  | "NOW" ->
      ok I_NOW
  | "OR" ->
      ok I_OR
  | "PAIR" ->
      ok I_PAIR
  | "PUSH" ->
      ok I_PUSH
  | "RIGHT" ->
      ok I_RIGHT
  | "SIZE" ->
      ok I_SIZE
  | "SOME" ->
      ok I_SOME
  | "SOURCE" ->
      ok I_SOURCE
  | "SENDER" ->
      ok I_SENDER
  | "SELF" ->
      ok I_SELF
  | "SLICE" ->
      ok I_SLICE
  | "STEPS_TO_QUOTA" ->
      ok I_STEPS_TO_QUOTA
  | "SUB" ->
      ok I_SUB
  | "SWAP" ->
      ok I_SWAP
  | "TRANSFER_TOKENS" ->
      ok I_TRANSFER_TOKENS
  | "SET_DELEGATE" ->
      ok I_SET_DELEGATE
  | "UNIT" ->
      ok I_UNIT
  | "UPDATE" ->
      ok I_UPDATE
  | "XOR" ->
      ok I_XOR
  | "ITER" ->
      ok I_ITER
  | "LOOP_LEFT" ->
      ok I_LOOP_LEFT
  | "ADDRESS" ->
      ok I_ADDRESS
  | "CONTRACT" ->
      ok I_CONTRACT
  | "ISNAT" ->
      ok I_ISNAT
  | "CAST" ->
      ok I_CAST
  | "RENAME" ->
      ok I_RENAME
  | "DIG" ->
      ok I_DIG
  | "DUG" ->
      ok I_DUG
  | "bool" ->
      ok T_bool
  | "contract" ->
      ok T_contract
  | "int" ->
      ok T_int
  | "key" ->
      ok T_key
  | "key_hash" ->
      ok T_key_hash
  | "lambda" ->
      ok T_lambda
  | "list" ->
      ok T_list
  | "map" ->
      ok T_map
  | "big_map" ->
      ok T_big_map
  | "nat" ->
      ok T_nat
  | "option" ->
      ok T_option
  | "or" ->
      ok T_or
  | "pair" ->
      ok T_pair
  | "set" ->
      ok T_set
  | "signature" ->
      ok T_signature
  | "string" ->
      ok T_string
  | "bytes" ->
      ok T_bytes
  | "mutez" ->
      ok T_mutez
  | "timestamp" ->
      ok T_timestamp
  | "unit" ->
      ok T_unit
  | "operation" ->
      ok T_operation
  | "address" ->
      ok T_address
  | "chain_id" ->
      ok T_chain_id
  | n ->
      if valid_case n then error (Unknown_primitive_name n)
      else error (Invalid_case n)

let prims_of_strings expr =
  let rec convert = function
    | Int (l, x) ->
        ok (Int (l, x))
    | String (l, x) ->
        ok (String (l, x))
    | Bytes (l, x) ->
        ok (Bytes (l, x))
    | Prim (loc, prim, args, annot) ->
        Error_monad.record_trace
          (Invalid_primitive_name (expr, loc))
          (prim_of_string prim)
        >>? fun prim ->
        List.fold_left
          (fun acc arg ->
            acc >>? fun args -> convert arg >>? fun arg -> ok (arg :: args))
          (ok [])
          args
        >>? fun args -> ok (Prim (0, prim, List.rev args, annot))
    | Seq (_, args) ->
        List.fold_left
          (fun acc arg ->
            acc >>? fun args -> convert arg >>? fun arg -> ok (arg :: args))
          (ok [])
          args
        >>? fun args -> ok (Seq (0, List.rev args))
  in
  convert (root expr) >>? fun expr -> ok (strip_locations expr)

let strings_of_prims expr =
  let rec convert = function
    | Int (l, x) ->
        Int (l, x)
    | String (l, x) ->
        String (l, x)
    | Bytes (l, x) ->
        Bytes (l, x)
    | Prim (_, prim, args, annot) ->
        let prim = string_of_prim prim in
        let args = List.map convert args in
        Prim (0, prim, args, annot)
    | Seq (_, args) ->
        let args = List.map convert args in
        Seq (0, args)
  in
  strip_locations (convert (root expr))

let prim_encoding =
  let open Data_encoding in
  def "michelson.v1.primitives"
  @@ string_enum
       [ (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("parameter", K_parameter);
         ("storage", K_storage);
         ("code", K_code);
         ("False", D_False);
         ("Elt", D_Elt);
         ("Left", D_Left);
         ("None", D_None);
         ("Pair", D_Pair);
         ("Right", D_Right);
         ("Some", D_Some);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("True", D_True);
         ("Unit", D_Unit);
         ("PACK", I_PACK);
         ("UNPACK", I_UNPACK);
         ("BLAKE2B", I_BLAKE2B);
         ("SHA256", I_SHA256);
         ("SHA512", I_SHA512);
         ("ABS", I_ABS);
         ("ADD", I_ADD);
         ("AMOUNT", I_AMOUNT);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("AND", I_AND);
         ("BALANCE", I_BALANCE);
         ("CAR", I_CAR);
         ("CDR", I_CDR);
         ("CHECK_SIGNATURE", I_CHECK_SIGNATURE);
         ("COMPARE", I_COMPARE);
         ("CONCAT", I_CONCAT);
         ("CONS", I_CONS);
         ("CREATE_ACCOUNT", I_CREATE_ACCOUNT);
         ("CREATE_CONTRACT", I_CREATE_CONTRACT);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT);
         ("DIP", I_DIP);
         ("DROP", I_DROP);
         ("DUP", I_DUP);
         ("EDIV", I_EDIV);
         ("EMPTY_MAP", I_EMPTY_MAP);
         ("EMPTY_SET", I_EMPTY_SET);
         ("EQ", I_EQ);
         ("EXEC", I_EXEC);
         ("FAILWITH", I_FAILWITH);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("GE", I_GE);
         ("GET", I_GET);
         ("GT", I_GT);
         ("HASH_KEY", I_HASH_KEY);
         ("IF", I_IF);
         ("IF_CONS", I_IF_CONS);
         ("IF_LEFT", I_IF_LEFT);
         ("IF_NONE", I_IF_NONE);
         ("INT", I_INT);
         ("LAMBDA", I_LAMBDA);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("LE", I_LE);
         ("LEFT", I_LEFT);
         ("LOOP", I_LOOP);
         ("LSL", I_LSL);
         ("LSR", I_LSR);
         ("LT", I_LT);
         ("MAP", I_MAP);
         ("MEM", I_MEM);
         ("MUL", I_MUL);
         ("NEG", I_NEG);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("NEQ", I_NEQ);
         ("NIL", I_NIL);
         ("NONE", I_NONE);
         ("NOT", I_NOT);
         ("NOW", I_NOW);
         ("OR", I_OR);
         ("PAIR", I_PAIR);
         ("PUSH", I_PUSH);
         ("RIGHT", I_RIGHT);
         ("SIZE", I_SIZE);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("SOME", I_SOME);
         ("SOURCE", I_SOURCE);
         ("SENDER", I_SENDER);
         ("SELF", I_SELF);
         ("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA);
         ("SUB", I_SUB);
         ("SWAP", I_SWAP);
         ("TRANSFER_TOKENS", I_TRANSFER_TOKENS);
         ("SET_DELEGATE", I_SET_DELEGATE);
         ("UNIT", I_UNIT);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("UPDATE", I_UPDATE);
         ("XOR", I_XOR);
         ("ITER", I_ITER);
         ("LOOP_LEFT", I_LOOP_LEFT);
         ("ADDRESS", I_ADDRESS);
         ("CONTRACT", I_CONTRACT);
         ("ISNAT", I_ISNAT);
         ("CAST", I_CAST);
         ("RENAME", I_RENAME);
         ("bool", T_bool);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("contract", T_contract);
         ("int", T_int);
         ("key", T_key);
         ("key_hash", T_key_hash);
         ("lambda", T_lambda);
         ("list", T_list);
         ("map", T_map);
         ("big_map", T_big_map);
         ("nat", T_nat);
         ("option", T_option);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("or", T_or);
         ("pair", T_pair);
         ("set", T_set);
         ("signature", T_signature);
         ("string", T_string);
         ("bytes", T_bytes);
         ("mutez", T_mutez);
         ("timestamp", T_timestamp);
         ("unit", T_unit);
         ("operation", T_operation);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("address", T_address);
         (* Alpha_002 addition *)
         ("SLICE", I_SLICE);
         (* Alpha_005 addition *)
         ("DIG", I_DIG);
         ("DUG", I_DUG);
         ("EMPTY_BIG_MAP", I_EMPTY_BIG_MAP);
         ("APPLY", I_APPLY);
         ("chain_id", T_chain_id);
         ("CHAIN_ID", I_CHAIN_ID)
         (* New instructions must be added here, for backward compatibility of the encoding. *)
        ]

let () =
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unknown_primitive_name"
    ~title:"Unknown primitive name"
    ~description:"In a script or data expression, a primitive was unknown."
    ~pp:(fun ppf n -> Format.fprintf ppf "Unknown primitive %s." n)
    Data_encoding.(obj1 (req "wrong_primitive_name" string))
    (function Unknown_primitive_name got -> Some got | _ -> None)
    (fun got -> Unknown_primitive_name got) ;
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_primitive_name_case"
    ~title:"Invalid primitive name case"
    ~description:
      "In a script or data expression, a primitive name is neither uppercase, \
       lowercase or capitalized."
    ~pp:(fun ppf n -> Format.fprintf ppf "Primitive %s has invalid case." n)
    Data_encoding.(obj1 (req "wrong_primitive_name" string))
    (function Invalid_case name -> Some name | _ -> None)
    (fun name -> Invalid_case name) ;
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_primitive_name"
    ~title:"Invalid primitive name"
    ~description:
      "In a script or data expression, a primitive name is unknown or has a \
       wrong case."
    ~pp:(fun ppf _ -> Format.fprintf ppf "Invalid primitive.")
    Data_encoding.(
      obj2
        (req
           "expression"
           (Micheline.canonical_encoding ~variant:"generic" string))
        (req "location" Micheline.canonical_location_encoding))
    (function
      | Invalid_primitive_name (expr, loc) -> Some (expr, loc) | _ -> None)
    (fun (expr, loc) -> Invalid_primitive_name (expr, loc))
Michelson_v1_primitives.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Import Micheline.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

Inductive prim : Set :=
| K_parameter : prim
| K_storage : prim
| K_code : prim
| D_False : prim
| D_Elt : prim
| D_Left : prim
| D_None : prim
| D_Pair : prim
| D_Right : prim
| D_Some : prim
| D_True : prim
| D_Unit : prim
| I_PACK : prim
| I_UNPACK : prim
| I_BLAKE2B : prim
| I_SHA256 : prim
| I_SHA512 : prim
| I_ABS : prim
| I_ADD : prim
| I_AMOUNT : prim
| I_AND : prim
| I_BALANCE : prim
| I_CAR : prim
| I_CDR : prim
| I_CHAIN_ID : prim
| I_CHECK_SIGNATURE : prim
| I_COMPARE : prim
| I_CONCAT : prim
| I_CONS : prim
| I_CREATE_ACCOUNT : prim
| I_CREATE_CONTRACT : prim
| I_IMPLICIT_ACCOUNT : prim
| I_DIP : prim
| I_DROP : prim
| I_DUP : prim
| I_EDIV : prim
| I_EMPTY_BIG_MAP : prim
| I_EMPTY_MAP : prim
| I_EMPTY_SET : prim
| I_EQ : prim
| I_EXEC : prim
| I_APPLY : prim
| I_FAILWITH : prim
| I_GE : prim
| I_GET : prim
| I_GT : prim
| I_HASH_KEY : prim
| I_IF : prim
| I_IF_CONS : prim
| I_IF_LEFT : prim
| I_IF_NONE : prim
| I_INT : prim
| I_LAMBDA : prim
| I_LE : prim
| I_LEFT : prim
| I_LOOP : prim
| I_LSL : prim
| I_LSR : prim
| I_LT : prim
| I_MAP : prim
| I_MEM : prim
| I_MUL : prim
| I_NEG : prim
| I_NEQ : prim
| I_NIL : prim
| I_NONE : prim
| I_NOT : prim
| I_NOW : prim
| I_OR : prim
| I_PAIR : prim
| I_PUSH : prim
| I_RIGHT : prim
| I_SIZE : prim
| I_SOME : prim
| I_SOURCE : prim
| I_SENDER : prim
| I_SELF : prim
| I_SLICE : prim
| I_STEPS_TO_QUOTA : prim
| I_SUB : prim
| I_SWAP : prim
| I_TRANSFER_TOKENS : prim
| I_SET_DELEGATE : prim
| I_UNIT : prim
| I_UPDATE : prim
| I_XOR : prim
| I_ITER : prim
| I_LOOP_LEFT : prim
| I_ADDRESS : prim
| I_CONTRACT : prim
| I_ISNAT : prim
| I_CAST : prim
| I_RENAME : prim
| I_DIG : prim
| I_DUG : prim
| T_bool : prim
| T_contract : prim
| T_int : prim
| T_key : prim
| T_key_hash : prim
| T_lambda : prim
| T_list : prim
| T_map : prim
| T_big_map : prim
| T_nat : prim
| T_option : prim
| T_or : prim
| T_pair : prim
| T_set : prim
| T_signature : prim
| T_string : prim
| T_bytes : prim
| T_mutez : prim
| T_timestamp : prim
| T_unit : prim
| T_operation : prim
| T_address : prim
| T_chain_id : prim.

Definition valid_case (name : string) : bool :=
  let is_lower (function_parameter : ascii) : bool :=
    match function_parameter with
    |
      "_" % char | "a" % char | "b" % char | "c" % char | "d" % char |
      "e" % char | "f" % char | "g" % char | "h" % char | "i" % char |
      "j" % char | "k" % char | "l" % char | "m" % char | "n" % char |
      "o" % char | "p" % char | "q" % char | "r" % char | "s" % char |
      "t" % char | "u" % char | "v" % char | "w" % char | "x" % char |
      "y" % char | "z" % char => true
    | _ => false
    end in
  let is_upper (function_parameter : ascii) : bool :=
    match function_parameter with
    |
      "_" % char | "A" % char | "B" % char | "C" % char | "D" % char |
      "E" % char | "F" % char | "G" % char | "H" % char | "I" % char |
      "J" % char | "K" % char | "L" % char | "M" % char | "N" % char |
      "O" % char | "P" % char | "Q" % char | "R" % char | "S" % char |
      "T" % char | "U" % char | "V" % char | "W" % char | "X" % char |
      "Y" % char | "Z" % char => true
    | _ => false
    end in
  let fix for_all
    (a : (|Compare.Int|).(Compare.S.t)) (b : (|Compare.Int|).(Compare.S.t))
    (f : (|Compare.Int|).(Compare.S.t) -> bool) {struct a} : bool :=
    Pervasives.op_pipepipe ((|Compare.Int|).(Compare.S.op_gt) a b)
      (Pervasives.op_andand (f a) (for_all (Pervasives.op_plus a 1) b f)) in
  let len := String.length name in
  Pervasives.op_andand ((|Compare.Int|).(Compare.S.op_ltgt) len 0)
    (Pervasives.op_andand
      ((|Compare.Char|).(Compare.S.op_ltgt) (String.get name 0) "_" % char)
      (Pervasives.op_pipepipe
        (Pervasives.op_andand (is_upper (String.get name 0))
          (for_all 1 (Pervasives.op_minus len 1)
            (fun i => is_upper (String.get name i))))
        (Pervasives.op_pipepipe
          (Pervasives.op_andand (is_upper (String.get name 0))
            (for_all 1 (Pervasives.op_minus len 1)
              (fun i => is_lower (String.get name i))))
          (Pervasives.op_andand (is_lower (String.get name 0))
            (for_all 1 (Pervasives.op_minus len 1)
              (fun i => is_lower (String.get name i))))))).

Definition string_of_prim (function_parameter : prim) : string :=
  match function_parameter with
  | K_parameter => "parameter"
  | K_storage => "storage"
  | K_code => "code"
  | D_False => "False"
  | D_Elt => "Elt"
  | D_Left => "Left"
  | D_None => "None"
  | D_Pair => "Pair"
  | D_Right => "Right"
  | D_Some => "Some"
  | D_True => "True"
  | D_Unit => "Unit"
  | I_PACK => "PACK"
  | I_UNPACK => "UNPACK"
  | I_BLAKE2B => "BLAKE2B"
  | I_SHA256 => "SHA256"
  | I_SHA512 => "SHA512"
  | I_ABS => "ABS"
  | I_ADD => "ADD"
  | I_AMOUNT => "AMOUNT"
  | I_AND => "AND"
  | I_BALANCE => "BALANCE"
  | I_CAR => "CAR"
  | I_CDR => "CDR"
  | I_CHAIN_ID => "CHAIN_ID"
  | I_CHECK_SIGNATURE => "CHECK_SIGNATURE"
  | I_COMPARE => "COMPARE"
  | I_CONCAT => "CONCAT"
  | I_CONS => "CONS"
  | I_CREATE_ACCOUNT => "CREATE_ACCOUNT"
  | I_CREATE_CONTRACT => "CREATE_CONTRACT"
  | I_IMPLICIT_ACCOUNT => "IMPLICIT_ACCOUNT"
  | I_DIP => "DIP"
  | I_DROP => "DROP"
  | I_DUP => "DUP"
  | I_EDIV => "EDIV"
  | I_EMPTY_BIG_MAP => "EMPTY_BIG_MAP"
  | I_EMPTY_MAP => "EMPTY_MAP"
  | I_EMPTY_SET => "EMPTY_SET"
  | I_EQ => "EQ"
  | I_EXEC => "EXEC"
  | I_APPLY => "APPLY"
  | I_FAILWITH => "FAILWITH"
  | I_GE => "GE"
  | I_GET => "GET"
  | I_GT => "GT"
  | I_HASH_KEY => "HASH_KEY"
  | I_IF => "IF"
  | I_IF_CONS => "IF_CONS"
  | I_IF_LEFT => "IF_LEFT"
  | I_IF_NONE => "IF_NONE"
  | I_INT => "INT"
  | I_LAMBDA => "LAMBDA"
  | I_LE => "LE"
  | I_LEFT => "LEFT"
  | I_LOOP => "LOOP"
  | I_LSL => "LSL"
  | I_LSR => "LSR"
  | I_LT => "LT"
  | I_MAP => "MAP"
  | I_MEM => "MEM"
  | I_MUL => "MUL"
  | I_NEG => "NEG"
  | I_NEQ => "NEQ"
  | I_NIL => "NIL"
  | I_NONE => "NONE"
  | I_NOT => "NOT"
  | I_NOW => "NOW"
  | I_OR => "OR"
  | I_PAIR => "PAIR"
  | I_PUSH => "PUSH"
  | I_RIGHT => "RIGHT"
  | I_SIZE => "SIZE"
  | I_SOME => "SOME"
  | I_SOURCE => "SOURCE"
  | I_SENDER => "SENDER"
  | I_SELF => "SELF"
  | I_SLICE => "SLICE"
  | I_STEPS_TO_QUOTA => "STEPS_TO_QUOTA"
  | I_SUB => "SUB"
  | I_SWAP => "SWAP"
  | I_TRANSFER_TOKENS => "TRANSFER_TOKENS"
  | I_SET_DELEGATE => "SET_DELEGATE"
  | I_UNIT => "UNIT"
  | I_UPDATE => "UPDATE"
  | I_XOR => "XOR"
  | I_ITER => "ITER"
  | I_LOOP_LEFT => "LOOP_LEFT"
  | I_ADDRESS => "ADDRESS"
  | I_CONTRACT => "CONTRACT"
  | I_ISNAT => "ISNAT"
  | I_CAST => "CAST"
  | I_RENAME => "RENAME"
  | I_DIG => "DIG"
  | I_DUG => "DUG"
  | T_bool => "bool"
  | T_contract => "contract"
  | T_int => "int"
  | T_key => "key"
  | T_key_hash => "key_hash"
  | T_lambda => "lambda"
  | T_list => "list"
  | T_map => "map"
  | T_big_map => "big_map"
  | T_nat => "nat"
  | T_option => "option"
  | T_or => "or"
  | T_pair => "pair"
  | T_set => "set"
  | T_signature => "signature"
  | T_string => "string"
  | T_bytes => "bytes"
  | T_mutez => "mutez"
  | T_timestamp => "timestamp"
  | T_unit => "unit"
  | T_operation => "operation"
  | T_address => "address"
  | T_chain_id => "chain_id"
  end.

Definition prim_of_string (function_parameter : string)
  : Error_monad.tzresult prim :=
  match function_parameter with
  | "parameter" => Error_monad.ok K_parameter
  | "storage" => Error_monad.ok K_storage
  | "code" => Error_monad.ok K_code
  | "False" => Error_monad.ok D_False
  | "Elt" => Error_monad.ok D_Elt
  | "Left" => Error_monad.ok D_Left
  | "None" => Error_monad.ok D_None
  | "Pair" => Error_monad.ok D_Pair
  | "Right" => Error_monad.ok D_Right
  | "Some" => Error_monad.ok D_Some
  | "True" => Error_monad.ok D_True
  | "Unit" => Error_monad.ok D_Unit
  | "PACK" => Error_monad.ok I_PACK
  | "UNPACK" => Error_monad.ok I_UNPACK
  | "BLAKE2B" => Error_monad.ok I_BLAKE2B
  | "SHA256" => Error_monad.ok I_SHA256
  | "SHA512" => Error_monad.ok I_SHA512
  | "ABS" => Error_monad.ok I_ABS
  | "ADD" => Error_monad.ok I_ADD
  | "AMOUNT" => Error_monad.ok I_AMOUNT
  | "AND" => Error_monad.ok I_AND
  | "BALANCE" => Error_monad.ok I_BALANCE
  | "CAR" => Error_monad.ok I_CAR
  | "CDR" => Error_monad.ok I_CDR
  | "CHAIN_ID" => Error_monad.ok I_CHAIN_ID
  | "CHECK_SIGNATURE" => Error_monad.ok I_CHECK_SIGNATURE
  | "COMPARE" => Error_monad.ok I_COMPARE
  | "CONCAT" => Error_monad.ok I_CONCAT
  | "CONS" => Error_monad.ok I_CONS
  | "CREATE_ACCOUNT" => Error_monad.ok I_CREATE_ACCOUNT
  | "CREATE_CONTRACT" => Error_monad.ok I_CREATE_CONTRACT
  | "IMPLICIT_ACCOUNT" => Error_monad.ok I_IMPLICIT_ACCOUNT
  | "DIP" => Error_monad.ok I_DIP
  | "DROP" => Error_monad.ok I_DROP
  | "DUP" => Error_monad.ok I_DUP
  | "EDIV" => Error_monad.ok I_EDIV
  | "EMPTY_BIG_MAP" => Error_monad.ok I_EMPTY_BIG_MAP
  | "EMPTY_MAP" => Error_monad.ok I_EMPTY_MAP
  | "EMPTY_SET" => Error_monad.ok I_EMPTY_SET
  | "EQ" => Error_monad.ok I_EQ
  | "EXEC" => Error_monad.ok I_EXEC
  | "APPLY" => Error_monad.ok I_APPLY
  | "FAILWITH" => Error_monad.ok I_FAILWITH
  | "GE" => Error_monad.ok I_GE
  | "GET" => Error_monad.ok I_GET
  | "GT" => Error_monad.ok I_GT
  | "HASH_KEY" => Error_monad.ok I_HASH_KEY
  | "IF" => Error_monad.ok I_IF
  | "IF_CONS" => Error_monad.ok I_IF_CONS
  | "IF_LEFT" => Error_monad.ok I_IF_LEFT
  | "IF_NONE" => Error_monad.ok I_IF_NONE
  | "INT" => Error_monad.ok I_INT
  | "LAMBDA" => Error_monad.ok I_LAMBDA
  | "LE" => Error_monad.ok I_LE
  | "LEFT" => Error_monad.ok I_LEFT
  | "LOOP" => Error_monad.ok I_LOOP
  | "LSL" => Error_monad.ok I_LSL
  | "LSR" => Error_monad.ok I_LSR
  | "LT" => Error_monad.ok I_LT
  | "MAP" => Error_monad.ok I_MAP
  | "MEM" => Error_monad.ok I_MEM
  | "MUL" => Error_monad.ok I_MUL
  | "NEG" => Error_monad.ok I_NEG
  | "NEQ" => Error_monad.ok I_NEQ
  | "NIL" => Error_monad.ok I_NIL
  | "NONE" => Error_monad.ok I_NONE
  | "NOT" => Error_monad.ok I_NOT
  | "NOW" => Error_monad.ok I_NOW
  | "OR" => Error_monad.ok I_OR
  | "PAIR" => Error_monad.ok I_PAIR
  | "PUSH" => Error_monad.ok I_PUSH
  | "RIGHT" => Error_monad.ok I_RIGHT
  | "SIZE" => Error_monad.ok I_SIZE
  | "SOME" => Error_monad.ok I_SOME
  | "SOURCE" => Error_monad.ok I_SOURCE
  | "SENDER" => Error_monad.ok I_SENDER
  | "SELF" => Error_monad.ok I_SELF
  | "SLICE" => Error_monad.ok I_SLICE
  | "STEPS_TO_QUOTA" => Error_monad.ok I_STEPS_TO_QUOTA
  | "SUB" => Error_monad.ok I_SUB
  | "SWAP" => Error_monad.ok I_SWAP
  | "TRANSFER_TOKENS" => Error_monad.ok I_TRANSFER_TOKENS
  | "SET_DELEGATE" => Error_monad.ok I_SET_DELEGATE
  | "UNIT" => Error_monad.ok I_UNIT
  | "UPDATE" => Error_monad.ok I_UPDATE
  | "XOR" => Error_monad.ok I_XOR
  | "ITER" => Error_monad.ok I_ITER
  | "LOOP_LEFT" => Error_monad.ok I_LOOP_LEFT
  | "ADDRESS" => Error_monad.ok I_ADDRESS
  | "CONTRACT" => Error_monad.ok I_CONTRACT
  | "ISNAT" => Error_monad.ok I_ISNAT
  | "CAST" => Error_monad.ok I_CAST
  | "RENAME" => Error_monad.ok I_RENAME
  | "DIG" => Error_monad.ok I_DIG
  | "DUG" => Error_monad.ok I_DUG
  | "bool" => Error_monad.ok T_bool
  | "contract" => Error_monad.ok T_contract
  | "int" => Error_monad.ok T_int
  | "key" => Error_monad.ok T_key
  | "key_hash" => Error_monad.ok T_key_hash
  | "lambda" => Error_monad.ok T_lambda
  | "list" => Error_monad.ok T_list
  | "map" => Error_monad.ok T_map
  | "big_map" => Error_monad.ok T_big_map
  | "nat" => Error_monad.ok T_nat
  | "option" => Error_monad.ok T_option
  | "or" => Error_monad.ok T_or
  | "pair" => Error_monad.ok T_pair
  | "set" => Error_monad.ok T_set
  | "signature" => Error_monad.ok T_signature
  | "string" => Error_monad.ok T_string
  | "bytes" => Error_monad.ok T_bytes
  | "mutez" => Error_monad.ok T_mutez
  | "timestamp" => Error_monad.ok T_timestamp
  | "unit" => Error_monad.ok T_unit
  | "operation" => Error_monad.ok T_operation
  | "address" => Error_monad.ok T_address
  | "chain_id" => Error_monad.ok T_chain_id
  | n =>
    if valid_case n then
      Error_monad.__error_value extensible_type_value
    else
      Error_monad.__error_value extensible_type_value
  end.

Definition prims_of_strings (expr : Micheline.canonical string)
  : Error_monad.tzresult (Micheline.canonical prim) :=
  let fix convert
    (function_parameter : Micheline.node Micheline.canonical_location string)
    {struct function_parameter}
    : Error_monad.tzresult (Micheline.node Micheline.canonical_location prim) :=
    match function_parameter with
    | Micheline.Int l x => Error_monad.ok (Micheline.Int l x)
    | Micheline.String l x => Error_monad.ok (Micheline.String l x)
    | Micheline.Bytes l x => Error_monad.ok (Micheline.Bytes l x)
    | Micheline.Prim loc prim args annot =>
      Error_monad.op_gtgtquestion
        (Error_monad.record_trace extensible_type_value (prim_of_string prim))
        (fun prim =>
          Error_monad.op_gtgtquestion
            (List.fold_left
              (fun acc =>
                fun arg =>
                  Error_monad.op_gtgtquestion acc
                    (fun args =>
                      Error_monad.op_gtgtquestion (convert arg)
                        (fun arg => Error_monad.ok (cons arg args))))
              (Error_monad.ok []) args)
            (fun args =>
              Error_monad.ok (Micheline.Prim 0 prim (List.rev args) annot)))
    | Micheline.Seq _ args =>
      Error_monad.op_gtgtquestion
        (List.fold_left
          (fun acc =>
            fun arg =>
              Error_monad.op_gtgtquestion acc
                (fun args =>
                  Error_monad.op_gtgtquestion (convert arg)
                    (fun arg => Error_monad.ok (cons arg args))))
          (Error_monad.ok []) args)
        (fun args => Error_monad.ok (Micheline.Seq 0 (List.rev args)))
    end in
  Error_monad.op_gtgtquestion (convert (Micheline.root expr))
    (fun expr => Error_monad.ok (Micheline.strip_locations expr)).

Definition strings_of_prims (expr : Micheline.canonical prim)
  : Micheline.canonical string :=
  let fix convert (function_parameter : Micheline.node Z prim)
    {struct function_parameter} : Micheline.node Z string :=
    match function_parameter with
    | Micheline.Int l x => Micheline.Int l x
    | Micheline.String l x => Micheline.String l x
    | Micheline.Bytes l x => Micheline.Bytes l x
    | Micheline.Prim _ prim args annot =>
      let prim := string_of_prim prim in
      let args := List.map convert args in
      Micheline.Prim 0 prim args annot
    | Micheline.Seq _ args =>
      let args := List.map convert args in
      Micheline.Seq 0 args
    end in
  Micheline.strip_locations (convert (Micheline.root expr)).

Definition prim_encoding : Data_encoding.encoding prim :=
  Pervasives.op_atat
    (let arg := Data_encoding.def "michelson.v1.primitives" in
    fun eta => arg None None eta)
    (Data_encoding.string_enum
      [
        ("parameter", K_parameter);
        ("storage", K_storage);
        ("code", K_code);
        ("False", D_False);
        ("Elt", D_Elt);
        ("Left", D_Left);
        ("None", D_None);
        ("Pair", D_Pair);
        ("Right", D_Right);
        ("Some", D_Some);
        ("True", D_True);
        ("Unit", D_Unit);
        ("PACK", I_PACK);
        ("UNPACK", I_UNPACK);
        ("BLAKE2B", I_BLAKE2B);
        ("SHA256", I_SHA256);
        ("SHA512", I_SHA512);
        ("ABS", I_ABS);
        ("ADD", I_ADD);
        ("AMOUNT", I_AMOUNT);
        ("AND", I_AND);
        ("BALANCE", I_BALANCE);
        ("CAR", I_CAR);
        ("CDR", I_CDR);
        ("CHECK_SIGNATURE", I_CHECK_SIGNATURE);
        ("COMPARE", I_COMPARE);
        ("CONCAT", I_CONCAT);
        ("CONS", I_CONS);
        ("CREATE_ACCOUNT", I_CREATE_ACCOUNT);
        ("CREATE_CONTRACT", I_CREATE_CONTRACT);
        ("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT);
        ("DIP", I_DIP);
        ("DROP", I_DROP);
        ("DUP", I_DUP);
        ("EDIV", I_EDIV);
        ("EMPTY_MAP", I_EMPTY_MAP);
        ("EMPTY_SET", I_EMPTY_SET);
        ("EQ", I_EQ);
        ("EXEC", I_EXEC);
        ("FAILWITH", I_FAILWITH);
        ("GE", I_GE);
        ("GET", I_GET);
        ("GT", I_GT);
        ("HASH_KEY", I_HASH_KEY);
        ("IF", I_IF);
        ("IF_CONS", I_IF_CONS);
        ("IF_LEFT", I_IF_LEFT);
        ("IF_NONE", I_IF_NONE);
        ("INT", I_INT);
        ("LAMBDA", I_LAMBDA);
        ("LE", I_LE);
        ("LEFT", I_LEFT);
        ("LOOP", I_LOOP);
        ("LSL", I_LSL);
        ("LSR", I_LSR);
        ("LT", I_LT);
        ("MAP", I_MAP);
        ("MEM", I_MEM);
        ("MUL", I_MUL);
        ("NEG", I_NEG);
        ("NEQ", I_NEQ);
        ("NIL", I_NIL);
        ("NONE", I_NONE);
        ("NOT", I_NOT);
        ("NOW", I_NOW);
        ("OR", I_OR);
        ("PAIR", I_PAIR);
        ("PUSH", I_PUSH);
        ("RIGHT", I_RIGHT);
        ("SIZE", I_SIZE);
        ("SOME", I_SOME);
        ("SOURCE", I_SOURCE);
        ("SENDER", I_SENDER);
        ("SELF", I_SELF);
        ("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA);
        ("SUB", I_SUB);
        ("SWAP", I_SWAP);
        ("TRANSFER_TOKENS", I_TRANSFER_TOKENS);
        ("SET_DELEGATE", I_SET_DELEGATE);
        ("UNIT", I_UNIT);
        ("UPDATE", I_UPDATE);
        ("XOR", I_XOR);
        ("ITER", I_ITER);
        ("LOOP_LEFT", I_LOOP_LEFT);
        ("ADDRESS", I_ADDRESS);
        ("CONTRACT", I_CONTRACT);
        ("ISNAT", I_ISNAT);
        ("CAST", I_CAST);
        ("RENAME", I_RENAME);
        ("bool", T_bool);
        ("contract", T_contract);
        ("int", T_int);
        ("key", T_key);
        ("key_hash", T_key_hash);
        ("lambda", T_lambda);
        ("list", T_list);
        ("map", T_map);
        ("big_map", T_big_map);
        ("nat", T_nat);
        ("option", T_option);
        ("or", T_or);
        ("pair", T_pair);
        ("set", T_set);
        ("signature", T_signature);
        ("string", T_string);
        ("bytes", T_bytes);
        ("mutez", T_mutez);
        ("timestamp", T_timestamp);
        ("unit", T_unit);
        ("operation", T_operation);
        ("address", T_address);
        ("SLICE", I_SLICE);
        ("DIG", I_DIG);
        ("DUG", I_DUG);
        ("EMPTY_BIG_MAP", I_EMPTY_BIG_MAP);
        ("APPLY", I_APPLY);
        ("chain_id", T_chain_id);
        ("CHAIN_ID", I_CHAIN_ID)
      ]).

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Michelson_v1_primitives_mli

  • OCaml size: 165 lines
  • Coq size: 150 lines (-10% compared to OCaml)
michelson_v1_primitives.mli 3 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += Unknown_primitive_name of string (* `Permanent *)

type error += Invalid_case of string (* `Permanent *)

type error +=
  | Invalid_primitive_name of
      string Micheline.canonical * Micheline.canonical_location

(* `Permanent *)

type prim =
  | K_parameter
  | K_storage
  | K_code
  | D_False
  | D_Elt
  | D_Left
  | D_None
  | D_Pair
  | D_Right
  | D_Some
  | D_True
  | D_Unit
  | I_PACK
  | I_UNPACK
  | I_BLAKE2B
  | I_SHA256
  | I_SHA512
  | I_ABS
  | I_ADD
  | I_AMOUNT
  | I_AND
  | I_BALANCE
  | I_CAR
  | I_CDR
  | I_CHAIN_ID
  | I_CHECK_SIGNATURE
  | I_COMPARE
  | I_CONCAT
  | I_CONS
  | I_CREATE_ACCOUNT
  | I_CREATE_CONTRACT
  | I_IMPLICIT_ACCOUNT
  | I_DIP
  | I_DROP
  | I_DUP
  | I_EDIV
  | I_EMPTY_BIG_MAP
  | I_EMPTY_MAP
  | I_EMPTY_SET
  | I_EQ
  | I_EXEC
  | I_APPLY
  | I_FAILWITH
  | I_GE
  | I_GET
  | I_GT
  | I_HASH_KEY
  | I_IF
  | I_IF_CONS
  | I_IF_LEFT
  | I_IF_NONE
  | I_INT
  | I_LAMBDA
  | I_LE
  | I_LEFT
  | I_LOOP
  | I_LSL
  | I_LSR
  | I_LT
  | I_MAP
  | I_MEM
  | I_MUL
  | I_NEG
  | I_NEQ
  | I_NIL
  | I_NONE
  | I_NOT
  | I_NOW
  | I_OR
  | I_PAIR
  | I_PUSH
  | I_RIGHT
  | I_SIZE
  | I_SOME
  | I_SOURCE
  | I_SENDER
  | I_SELF
  | I_SLICE
  | I_STEPS_TO_QUOTA
  | I_SUB
  | I_SWAP
  | I_TRANSFER_TOKENS
  | I_SET_DELEGATE
  | I_UNIT
  | I_UPDATE
  | I_XOR
  | I_ITER
  | I_LOOP_LEFT
  | I_ADDRESS
  | I_CONTRACT
  | I_ISNAT
  | I_CAST
  | I_RENAME
  | I_DIG
  | I_DUG
  | T_bool
  | T_contract
  | T_int
  | T_key
  | T_key_hash
  | T_lambda
  | T_list
  | T_map
  | T_big_map
  | T_nat
  | T_option
  | T_or
  | T_pair
  | T_set
  | T_signature
  | T_string
  | T_bytes
  | T_mutez
  | T_timestamp
  | T_unit
  | T_operation
  | T_address
  | T_chain_id

val prim_encoding : prim Data_encoding.encoding

val string_of_prim : prim -> string

val prim_of_string : string -> prim tzresult

val prims_of_strings :
  string Micheline.canonical -> prim Micheline.canonical tzresult

val strings_of_prims : prim Micheline.canonical -> string Micheline.canonical
Michelson_v1_primitives_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

(* extensible_type error *)

(* extensible_type error *)

(* extensible_type error *)

Inductive prim : Set :=
| K_parameter : prim
| K_storage : prim
| K_code : prim
| D_False : prim
| D_Elt : prim
| D_Left : prim
| D_None : prim
| D_Pair : prim
| D_Right : prim
| D_Some : prim
| D_True : prim
| D_Unit : prim
| I_PACK : prim
| I_UNPACK : prim
| I_BLAKE2B : prim
| I_SHA256 : prim
| I_SHA512 : prim
| I_ABS : prim
| I_ADD : prim
| I_AMOUNT : prim
| I_AND : prim
| I_BALANCE : prim
| I_CAR : prim
| I_CDR : prim
| I_CHAIN_ID : prim
| I_CHECK_SIGNATURE : prim
| I_COMPARE : prim
| I_CONCAT : prim
| I_CONS : prim
| I_CREATE_ACCOUNT : prim
| I_CREATE_CONTRACT : prim
| I_IMPLICIT_ACCOUNT : prim
| I_DIP : prim
| I_DROP : prim
| I_DUP : prim
| I_EDIV : prim
| I_EMPTY_BIG_MAP : prim
| I_EMPTY_MAP : prim
| I_EMPTY_SET : prim
| I_EQ : prim
| I_EXEC : prim
| I_APPLY : prim
| I_FAILWITH : prim
| I_GE : prim
| I_GET : prim
| I_GT : prim
| I_HASH_KEY : prim
| I_IF : prim
| I_IF_CONS : prim
| I_IF_LEFT : prim
| I_IF_NONE : prim
| I_INT : prim
| I_LAMBDA : prim
| I_LE : prim
| I_LEFT : prim
| I_LOOP : prim
| I_LSL : prim
| I_LSR : prim
| I_LT : prim
| I_MAP : prim
| I_MEM : prim
| I_MUL : prim
| I_NEG : prim
| I_NEQ : prim
| I_NIL : prim
| I_NONE : prim
| I_NOT : prim
| I_NOW : prim
| I_OR : prim
| I_PAIR : prim
| I_PUSH : prim
| I_RIGHT : prim
| I_SIZE : prim
| I_SOME : prim
| I_SOURCE : prim
| I_SENDER : prim
| I_SELF : prim
| I_SLICE : prim
| I_STEPS_TO_QUOTA : prim
| I_SUB : prim
| I_SWAP : prim
| I_TRANSFER_TOKENS : prim
| I_SET_DELEGATE : prim
| I_UNIT : prim
| I_UPDATE : prim
| I_XOR : prim
| I_ITER : prim
| I_LOOP_LEFT : prim
| I_ADDRESS : prim
| I_CONTRACT : prim
| I_ISNAT : prim
| I_CAST : prim
| I_RENAME : prim
| I_DIG : prim
| I_DUG : prim
| T_bool : prim
| T_contract : prim
| T_int : prim
| T_key : prim
| T_key_hash : prim
| T_lambda : prim
| T_list : prim
| T_map : prim
| T_big_map : prim
| T_nat : prim
| T_option : prim
| T_or : prim
| T_pair : prim
| T_set : prim
| T_signature : prim
| T_string : prim
| T_bytes : prim
| T_mutez : prim
| T_timestamp : prim
| T_unit : prim
| T_operation : prim
| T_address : prim
| T_chain_id : prim.

Parameter prim_encoding : Data_encoding.encoding prim.

Parameter string_of_prim : prim -> string.

Parameter prim_of_string : string -> Error_monad.tzresult prim.

Parameter prims_of_strings :
  Micheline.canonical string -> Error_monad.tzresult (Micheline.canonical prim).

Parameter strings_of_prims :
  Micheline.canonical prim -> Micheline.canonical string.

Misc

  • OCaml size: 91 lines
  • Coq size: 151 lines (+65% compared to OCaml)
misc.ml success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type 'a lazyt = unit -> 'a

type 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt

type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t

let rec ( --> ) i j =
  (* [i; i+1; ...; j] *)
  if Compare.Int.(i > j) then [] else i :: (succ i --> j)

let rec ( ---> ) i j =
  (* [i; i+1; ...; j] *)
  if Compare.Int32.(i > j) then [] else i :: (Int32.succ i ---> j)

let rec do_slashes delim path l acc limit i =
  if Compare.Int.(i >= l) then List.rev acc
  else if Compare.Char.(path.[i] = delim) then
    do_slashes delim path l acc limit (i + 1)
  else do_split delim path l acc limit i

and do_split delim path l acc limit i =
  if Compare.Int.(limit <= 0) then
    if Compare.Int.(i = l) then List.rev acc
    else List.rev (String.sub path i (l - i) :: acc)
  else do_component delim path l acc (pred limit) i i

and do_component delim path l acc limit i j =
  if Compare.Int.(j >= l) then
    if Compare.Int.(i = j) then List.rev acc
    else List.rev (String.sub path i (j - i) :: acc)
  else if Compare.Char.(path.[j] = delim) then
    do_slashes delim path l (String.sub path i (j - i) :: acc) limit j
  else do_component delim path l acc limit i (j + 1)

let split delim ?(limit = max_int) path =
  let l = String.length path in
  if Compare.Int.(limit > 0) then do_slashes delim path l [] limit 0 else [path]

let pp_print_paragraph ppf description =
  Format.fprintf
    ppf
    "@[%a@]"
    Format.(pp_print_list ~pp_sep:pp_print_space pp_print_string)
    (split ' ' description)

let take n l =
  let rec loop acc n xs =
    if Compare.Int.(n <= 0) then Some (List.rev acc, xs)
    else match xs with [] -> None | x :: xs -> loop (x :: acc) (n - 1) xs
  in
  loop [] n l

let remove_prefix ~prefix s =
  let x = String.length prefix in
  let n = String.length s in
  if Compare.Int.(n >= x) && Compare.String.(String.sub s 0 x = prefix) then
    Some (String.sub s x (n - x))
  else None

let rec remove_elem_from_list nb = function
  | [] ->
      []
  | _ :: _ as l when Compare.Int.(nb <= 0) ->
      l
  | _ :: tl ->
      remove_elem_from_list (nb - 1) tl
Misc.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Definition lazyt (a : Set) := unit -> a.

Inductive lazy_list_t (a : Set) : Set :=
| LCons :
  a -> lazyt (Lwt.t (Error_monad.tzresult (lazy_list_t a))) -> lazy_list_t a.

Arguments LCons {_}.

Definition lazy_list (a : Set) := Lwt.t (Error_monad.tzresult (lazy_list_t a)).

Fixpoint op_minusminusgt
  (i : (|Compare.Int|).(Compare.S.t)) (j : (|Compare.Int|).(Compare.S.t))
  {struct i} : list (|Compare.Int|).(Compare.S.t) :=
  if (|Compare.Int|).(Compare.S.op_gt) i j then
    []
  else
    cons i (op_minusminusgt (Pervasives.succ i) j).

Fixpoint op_minusminusminusgt
  (i : (|Compare.Int32|).(Compare.S.t)) (j : (|Compare.Int32|).(Compare.S.t))
  {struct i} : list (|Compare.Int32|).(Compare.S.t) :=
  if (|Compare.Int32|).(Compare.S.op_gt) i j then
    []
  else
    cons i (op_minusminusminusgt (Int32.succ i) j).

Fixpoint do_slashes
  (delim : (|Compare.Char|).(Compare.S.t)) (path : string)
  (l : (|Compare.Int|).(Compare.S.t)) (acc : list string)
  (limit : (|Compare.Int|).(Compare.S.t)) (i : (|Compare.Int|).(Compare.S.t))
  {struct delim} : list string :=
  if (|Compare.Int|).(Compare.S.op_gteq) i l then
    List.rev acc
  else
    if (|Compare.Char|).(Compare.S.op_eq) (String.get path i) delim then
      do_slashes delim path l acc limit (Pervasives.op_plus i 1)
    else
      do_split delim path l acc limit i

with do_split
  (delim : (|Compare.Char|).(Compare.S.t)) (path : string)
  (l : (|Compare.Int|).(Compare.S.t)) (acc : list string)
  (limit : (|Compare.Int|).(Compare.S.t)) (i : (|Compare.Int|).(Compare.S.t))
  {struct delim} : list string :=
  if (|Compare.Int|).(Compare.S.op_lteq) limit 0 then
    if (|Compare.Int|).(Compare.S.op_eq) i l then
      List.rev acc
    else
      List.rev (cons (String.sub path i (Pervasives.op_minus l i)) acc)
  else
    do_component delim path l acc (Pervasives.pred limit) i i

with do_component
  (delim : (|Compare.Char|).(Compare.S.t)) (path : string)
  (l : (|Compare.Int|).(Compare.S.t)) (acc : list string)
  (limit : (|Compare.Int|).(Compare.S.t)) (i : (|Compare.Int|).(Compare.S.t))
  (j : (|Compare.Int|).(Compare.S.t)) {struct delim} : list string :=
  if (|Compare.Int|).(Compare.S.op_gteq) j l then
    if (|Compare.Int|).(Compare.S.op_eq) i j then
      List.rev acc
    else
      List.rev (cons (String.sub path i (Pervasives.op_minus j i)) acc)
  else
    if (|Compare.Char|).(Compare.S.op_eq) (String.get path j) delim then
      do_slashes delim path l
        (cons (String.sub path i (Pervasives.op_minus j i)) acc) limit j
    else
      do_component delim path l acc limit i (Pervasives.op_plus j 1).

Definition split
  (delim : (|Compare.Char|).(Compare.S.t))
  (op_staroptstar : option (|Compare.Int|).(Compare.S.t))
  : string -> list string :=
  let limit :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Pervasives.max_int
    end in
  fun path =>
    let l := String.length path in
    if (|Compare.Int|).(Compare.S.op_gt) limit 0 then
      do_slashes delim path l [] limit 0
    else
      [ path ].

Definition pp_print_paragraph (ppf : Format.formatter) (description : string)
  : unit :=
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format ""))
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Close_box
            CamlinternalFormatBasics.End_of_format))) "@[%a@]")
    (Format.pp_print_list (Some Format.pp_print_space) Format.pp_print_string)
    (split " " % char None description).

Definition take {A : Set} (n : (|Compare.Int|).(Compare.S.t)) (l : list A)
  : option (list A * list A) :=
  let fix loop {B : Set}
    (acc : list B) (n : (|Compare.Int|).(Compare.S.t)) (xs : list B)
    {struct acc} : option (list B * list B) :=
    if (|Compare.Int|).(Compare.S.op_lteq) n 0 then
      Some ((List.rev acc), xs)
    else
      match xs with
      | [] => None
      | cons x xs => loop (cons x acc) (Pervasives.op_minus n 1) xs
      end in
  loop [] n l.

Definition remove_prefix
  (prefix : (|Compare.String|).(Compare.S.t)) (s : string) : option string :=
  let x := String.length prefix in
  let n := String.length s in
  if
    Pervasives.op_andand ((|Compare.Int|).(Compare.S.op_gteq) n x)
      ((|Compare.String|).(Compare.S.op_eq) (String.sub s 0 x) prefix) then
    Some (String.sub s x (Pervasives.op_minus n x))
  else
    None.

Fixpoint remove_elem_from_list {A : Set}
  (nb : (|Compare.Int|).(Compare.S.t)) (function_parameter : list A) {struct nb}
  : list A :=
  match
    (function_parameter,
      match function_parameter with
      | (cons _ _) as l => (|Compare.Int|).(Compare.S.op_lteq) nb 0
      | _ => false
      end) with
  | ([], _) => []
  | ((cons _ _) as l, true) => l
  | (cons _ tl, _) => remove_elem_from_list (Pervasives.op_minus nb 1) tl
  end.

Misc_mli

  • OCaml size: 47 lines
  • Coq size: 34 lines (-28% compared to OCaml)
misc.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** {2 Helper functions} *)

type 'a lazyt = unit -> 'a

type 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt

type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t

(** Include bounds *)
val ( --> ) : int -> int -> int list

val ( ---> ) : Int32.t -> Int32.t -> Int32.t list

val pp_print_paragraph : Format.formatter -> string -> unit

val take : int -> 'a list -> ('a list * 'a list) option

(** Some (input with [prefix] removed), if string has [prefix], else [None] *)
val remove_prefix : prefix:string -> string -> string option

(** [remove nb list] remove the first [nb] elements from the list [list]. *)
val remove_elem_from_list : int -> 'a list -> 'a list
Misc_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Definition lazyt (a : Set) := unit -> a.

Inductive lazy_list_t (a : Set) : Set :=
| LCons :
  a -> lazyt (Lwt.t (Error_monad.tzresult (lazy_list_t a))) -> lazy_list_t a.

Arguments LCons {_}.

Definition lazy_list (a : Set) := Lwt.t (Error_monad.tzresult (lazy_list_t a)).

Parameter op_minusminusgt : Z -> Z -> list Z.

Parameter op_minusminusminusgt : Int32.t -> Int32.t -> list Int32.t.

Parameter pp_print_paragraph : Format.formatter -> string -> unit.

Parameter take : forall {a : Set}, Z -> list a -> option (list a * list a).

Parameter remove_prefix : string -> string -> option string.

Parameter remove_elem_from_list : forall {a : Set}, Z -> list a -> list a.

Nonce_hash

  • OCaml size: 44 lines
  • Coq size: 103 lines (+134% compared to OCaml)
nonce_hash.ml 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* 32 *)
let nonce_hash = "\069\220\169" (* nce(53) *)

module Blake2BModule =
  Blake2B.Make
    (Base58)
    (struct
      let name = "cycle_nonce"

      let title = "A nonce hash"

      let b58check_prefix = nonce_hash

      let size = None
    end)

include Blake2BModule

let () = Base58.check_encoded_prefix b58check_encoding "nce" 53
Nonce_hash.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Definition nonce_hash : string := "E\220\169".

Definition Blake2BModule :=
  (Blake2B.Make
    (existT (fun _ => _) tt
      {|
        Blake2B.SRegister.register_encoding {_} := Base58.register_encoding
      |}))
    (let name := "cycle_nonce" in
    let title := "A nonce hash" in
    let b58check_prefix := nonce_hash in
    let size := None in
    existT (fun _ => _) tt
      {|
        Blake2B.PrefixedName.name := name;
        Blake2B.PrefixedName.title := title;
        Blake2B.PrefixedName.size := size;
        Blake2B.PrefixedName.b58check_prefix := b58check_prefix
      |}).

Definition t := (|Blake2BModule|).(S.HASH.t).

Definition name := (|Blake2BModule|).(S.HASH.name).

Definition title := (|Blake2BModule|).(S.HASH.title).

Definition pp := (|Blake2BModule|).(S.HASH.pp).

Definition pp_short := (|Blake2BModule|).(S.HASH.pp_short).

Definition op_eq := (|Blake2BModule|).(S.HASH.op_eq).

Definition op_ltgt := (|Blake2BModule|).(S.HASH.op_ltgt).

Definition op_lt := (|Blake2BModule|).(S.HASH.op_lt).

Definition op_lteq := (|Blake2BModule|).(S.HASH.op_lteq).

Definition op_gteq := (|Blake2BModule|).(S.HASH.op_gteq).

Definition op_gt := (|Blake2BModule|).(S.HASH.op_gt).

Definition compare := (|Blake2BModule|).(S.HASH.compare).

Definition equal := (|Blake2BModule|).(S.HASH.equal).

Definition max := (|Blake2BModule|).(S.HASH.max).

Definition min := (|Blake2BModule|).(S.HASH.min).

Definition hash_bytes := (|Blake2BModule|).(S.HASH.hash_bytes).

Definition hash_string := (|Blake2BModule|).(S.HASH.hash_string).

Definition zero := (|Blake2BModule|).(S.HASH.zero).

Definition size := (|Blake2BModule|).(S.HASH.size).

Definition to_bytes := (|Blake2BModule|).(S.HASH.to_bytes).

Definition of_bytes_opt := (|Blake2BModule|).(S.HASH.of_bytes_opt).

Definition of_bytes_exn := (|Blake2BModule|).(S.HASH.of_bytes_exn).

Definition to_b58check := (|Blake2BModule|).(S.HASH.to_b58check).

Definition to_short_b58check := (|Blake2BModule|).(S.HASH.to_short_b58check).

Definition of_b58check_exn := (|Blake2BModule|).(S.HASH.of_b58check_exn).

Definition of_b58check_opt := (|Blake2BModule|).(S.HASH.of_b58check_opt).

Definition b58check_encoding := (|Blake2BModule|).(S.HASH.b58check_encoding).

Definition encoding := (|Blake2BModule|).(S.HASH.encoding).

Definition rpc_arg := (|Blake2BModule|).(S.HASH.rpc_arg).

Definition to_path := (|Blake2BModule|).(S.HASH.to_path).

Definition of_path := (|Blake2BModule|).(S.HASH.of_path).

Definition of_path_exn := (|Blake2BModule|).(S.HASH.of_path_exn).

Definition prefix_path := (|Blake2BModule|).(S.HASH.prefix_path).

Definition path_length := (|Blake2BModule|).(S.HASH.path_length).

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Nonce_storage

  • OCaml size: 134 lines
  • Coq size: 112 lines (-17% compared to OCaml)
nonce_storage.ml 7 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Seed_repr.nonce

type nonce = t

let encoding = Seed_repr.nonce_encoding

type error +=
  | Too_late_revelation
  | Too_early_revelation
  | Previously_revealed_nonce
  | Unexpected_nonce

let () =
  register_error_kind
    `Branch
    ~id:"nonce.too_late_revelation"
    ~title:"Too late nonce revelation"
    ~description:"Nonce revelation happens too late"
    ~pp:(fun ppf () ->
      Format.fprintf ppf "This nonce cannot be revealed anymore.")
    Data_encoding.unit
    (function Too_late_revelation -> Some () | _ -> None)
    (fun () -> Too_late_revelation) ;
  register_error_kind
    `Temporary
    ~id:"nonce.too_early_revelation"
    ~title:"Too early nonce revelation"
    ~description:"Nonce revelation happens before cycle end"
    ~pp:(fun ppf () ->
      Format.fprintf ppf "This nonce should not yet be revealed")
    Data_encoding.unit
    (function Too_early_revelation -> Some () | _ -> None)
    (fun () -> Too_early_revelation) ;
  register_error_kind
    `Branch
    ~id:"nonce.previously_revealed"
    ~title:"Previously revealed nonce"
    ~description:"Duplicated revelation for a nonce."
    ~pp:(fun ppf () -> Format.fprintf ppf "This nonce was previously revealed")
    Data_encoding.unit
    (function Previously_revealed_nonce -> Some () | _ -> None)
    (fun () -> Previously_revealed_nonce) ;
  register_error_kind
    `Branch
    ~id:"nonce.unexpected"
    ~title:"Unexpected nonce"
    ~description:
      "The provided nonce is inconsistent with the committed nonce hash."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "This nonce revelation is invalid (inconsistent with the committed \
         hash)")
    Data_encoding.unit
    (function Unexpected_nonce -> Some () | _ -> None)
    (fun () -> Unexpected_nonce)

(* checks that the level of a revelation is not too early or too late wrt to the
   current context and that a nonce has not been already revealed for that level *)
let get_unrevealed ctxt level =
  let cur_level = Level_storage.current ctxt in
  match Cycle_repr.pred cur_level.cycle with
  | None ->
      fail Too_early_revelation (* no revelations during cycle 0 *)
  | Some revealed_cycle -> (
      if Cycle_repr.(revealed_cycle < level.Level_repr.cycle) then
        fail Too_early_revelation
      else if Cycle_repr.(level.Level_repr.cycle < revealed_cycle) then
        fail Too_late_revelation
      else
        Storage.Seed.Nonce.get ctxt level
        >>=? function
        | Revealed _ ->
            fail Previously_revealed_nonce
        | Unrevealed status ->
            return status )

let record_hash ctxt unrevealed =
  let level = Level_storage.current ctxt in
  Storage.Seed.Nonce.init ctxt level (Unrevealed unrevealed)

let reveal ctxt level nonce =
  get_unrevealed ctxt level
  >>=? fun unrevealed ->
  fail_unless
    (Seed_repr.check_hash nonce unrevealed.nonce_hash)
    Unexpected_nonce
  >>=? fun () ->
  Storage.Seed.Nonce.set ctxt level (Revealed nonce)
  >>=? fun ctxt -> return ctxt

type unrevealed = Storage.Seed.unrevealed_nonce = {
  nonce_hash : Nonce_hash.t;
  delegate : Signature.Public_key_hash.t;
  rewards : Tez_repr.t;
  fees : Tez_repr.t;
}

type status = Storage.Seed.nonce_status =
  | Unrevealed of unrevealed
  | Revealed of Seed_repr.nonce

let get = Storage.Seed.Nonce.get

let of_bytes = Seed_repr.make_nonce

let hash = Seed_repr.hash

let check_hash = Seed_repr.check_hash
Nonce_storage.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Cycle_repr.
Require Tezos.Level_repr.
Require Tezos.Level_storage.
Require Tezos.Nonce_hash.
Require Tezos.Raw_context.
Require Tezos.Seed_repr.
Require Tezos.Storage.
Require Tezos.Tez_repr.

Definition t := Seed_repr.nonce.

Definition nonce := t.

Definition encoding : Data_encoding.t Seed_repr.nonce :=
  Seed_repr.nonce_encoding.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition get_unrevealed (ctxt : Raw_context.t) (level : Level_repr.t)
  : Lwt.t (Error_monad.tzresult Storage.Seed.unrevealed_nonce) :=
  let cur_level := Level_storage.current ctxt in
  match Cycle_repr.pred (Level_repr.t.cycle cur_level) with
  | None => Error_monad.fail extensible_type_value
  | Some revealed_cycle =>
    if Cycle_repr.op_lt revealed_cycle (Level_repr.t.cycle level) then
      Error_monad.fail extensible_type_value
    else
      if Cycle_repr.op_lt (Level_repr.t.cycle level) revealed_cycle then
        Error_monad.fail extensible_type_value
      else
        Error_monad.op_gtgteqquestion (Storage.Seed.Nonce.get ctxt level)
          (fun function_parameter =>
            match function_parameter with
            | Storage.Seed.Revealed _ => Error_monad.fail extensible_type_value
            | Storage.Seed.Unrevealed status => Error_monad.__return status
            end)
  end.

Definition record_hash
  (ctxt : Raw_context.t) (unrevealed : Storage.Seed.unrevealed_nonce)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let level := Level_storage.current ctxt in
  Storage.Seed.Nonce.init ctxt level (Storage.Seed.Unrevealed unrevealed).

Definition reveal
  (ctxt : Raw_context.t) (level : Level_repr.t)
  (__nonce_value : Seed_repr.nonce)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Error_monad.op_gtgteqquestion (get_unrevealed ctxt level)
    (fun unrevealed =>
      Error_monad.op_gtgteqquestion
        (Error_monad.fail_unless
          (Seed_repr.check_hash __nonce_value
            (Storage.Seed.unrevealed_nonce.nonce_hash unrevealed))
          extensible_type_value)
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgteqquestion
            (Storage.Seed.Nonce.set ctxt level
              (Storage.Seed.Revealed __nonce_value))
            (fun ctxt => Error_monad.__return ctxt))).

Module unrevealed.
  Record record := Build {
    nonce_hash : Nonce_hash.t;
    delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
    rewards : Tez_repr.t;
    fees : Tez_repr.t }.
  Definition with_nonce_hash nonce_hash (r : record) :=
    Build nonce_hash r.(delegate) r.(rewards) r.(fees).
  Definition with_delegate delegate (r : record) :=
    Build r.(nonce_hash) delegate r.(rewards) r.(fees).
  Definition with_rewards rewards (r : record) :=
    Build r.(nonce_hash) r.(delegate) rewards r.(fees).
  Definition with_fees fees (r : record) :=
    Build r.(nonce_hash) r.(delegate) r.(rewards) fees.
End unrevealed.
Definition unrevealed := unrevealed.record.

Inductive status : Set :=
| Unrevealed : unrevealed -> status
| Revealed : Seed_repr.nonce -> status.

Definition get
  : Storage.Seed.Nonce.context -> Level_repr.t ->
  Lwt.t (Error_monad.tzresult Storage.Seed.nonce_status) :=
  Storage.Seed.Nonce.get.

Definition of_bytes : MBytes.t -> Error_monad.tzresult Seed_repr.nonce :=
  Seed_repr.make_nonce.

Definition __hash_value : Seed_repr.nonce -> Nonce_hash.t :=
  Seed_repr.__hash_value.

Definition check_hash : Seed_repr.nonce -> Nonce_hash.t -> bool :=
  Seed_repr.check_hash.

Nonce_storage_mli

  • OCaml size: 58 lines
  • Coq size: 62 lines (+6% compared to OCaml)
nonce_storage.mli 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error +=
  | Too_late_revelation
  | Too_early_revelation
  | Previously_revealed_nonce
  | Unexpected_nonce

type t = Seed_repr.nonce

type nonce = t

val encoding : nonce Data_encoding.t

type unrevealed = Storage.Seed.unrevealed_nonce = {
  nonce_hash : Nonce_hash.t;
  delegate : Signature.Public_key_hash.t;
  rewards : Tez_repr.t;
  fees : Tez_repr.t;
}

type status = Unrevealed of unrevealed | Revealed of Seed_repr.nonce

val get : Raw_context.t -> Level_repr.t -> status tzresult Lwt.t

val record_hash : Raw_context.t -> unrevealed -> Raw_context.t tzresult Lwt.t

val reveal :
  Raw_context.t -> Level_repr.t -> nonce -> Raw_context.t tzresult Lwt.t

val of_bytes : MBytes.t -> nonce tzresult

val hash : nonce -> Nonce_hash.t

val check_hash : nonce -> Nonce_hash.t -> bool
Nonce_storage_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Level_repr.
Require Tezos.Nonce_hash.
Require Tezos.Raw_context.
Require Tezos.Seed_repr.
Require Tezos.Tez_repr.

(* extensible_type error *)

Definition t := Seed_repr.nonce.

Definition nonce := t.

Parameter encoding : Data_encoding.t nonce.

Module unrevealed.
  Record record := Build {
    nonce_hash : Nonce_hash.t;
    delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
    rewards : Tez_repr.t;
    fees : Tez_repr.t }.
  Definition with_nonce_hash nonce_hash (r : record) :=
    Build nonce_hash r.(delegate) r.(rewards) r.(fees).
  Definition with_delegate delegate (r : record) :=
    Build r.(nonce_hash) delegate r.(rewards) r.(fees).
  Definition with_rewards rewards (r : record) :=
    Build r.(nonce_hash) r.(delegate) rewards r.(fees).
  Definition with_fees fees (r : record) :=
    Build r.(nonce_hash) r.(delegate) r.(rewards) fees.
End unrevealed.
Definition unrevealed := unrevealed.record.

Inductive status : Set :=
| Unrevealed : unrevealed -> status
| Revealed : Seed_repr.nonce -> status.

Parameter get :
  Raw_context.t -> Level_repr.t -> Lwt.t (Error_monad.tzresult status).

Parameter record_hash :
  Raw_context.t -> unrevealed -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter reveal :
  Raw_context.t -> Level_repr.t -> nonce ->
  Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter of_bytes : MBytes.t -> Error_monad.tzresult nonce.

Parameter __hash_value : nonce -> Nonce_hash.t.

Parameter check_hash : nonce -> Nonce_hash.t -> bool.

Operation_repr

  • OCaml size: 856 lines
  • Coq size: 1387 lines (+62% compared to OCaml)
operation_repr.ml 8 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Low level Repr. of Operations *)

module Kind = struct
  type seed_nonce_revelation = Seed_nonce_revelation_kind

  type double_endorsement_evidence = Double_endorsement_evidence_kind

  type double_baking_evidence = Double_baking_evidence_kind

  type activate_account = Activate_account_kind

  type endorsement = Endorsement_kind

  type proposals = Proposals_kind

  type ballot = Ballot_kind

  type reveal = Reveal_kind

  type transaction = Transaction_kind

  type origination = Origination_kind

  type delegation = Delegation_kind

  type 'a manager =
    | Reveal_manager_kind : reveal manager
    | Transaction_manager_kind : transaction manager
    | Origination_manager_kind : origination manager
    | Delegation_manager_kind : delegation manager
end

type raw = Operation.t = {shell : Operation.shell_header; proto : MBytes.t}

let raw_encoding = Operation.encoding

type 'kind operation = {
  shell : Operation.shell_header;
  protocol_data : 'kind protocol_data;
}

and 'kind protocol_data = {
  contents : 'kind contents_list;
  signature : Signature.t option;
}

and _ contents_list =
  | Single : 'kind contents -> 'kind contents_list
  | Cons :
      'kind Kind.manager contents * 'rest Kind.manager contents_list
      -> ('kind * 'rest) Kind.manager contents_list

and _ contents =
  | Endorsement : {level : Raw_level_repr.t} -> Kind.endorsement contents
  | Seed_nonce_revelation : {
      level : Raw_level_repr.t;
      nonce : Seed_repr.nonce;
    }
      -> Kind.seed_nonce_revelation contents
  | Double_endorsement_evidence : {
      op1 : Kind.endorsement operation;
      op2 : Kind.endorsement operation;
    }
      -> Kind.double_endorsement_evidence contents
  | Double_baking_evidence : {
      bh1 : Block_header_repr.t;
      bh2 : Block_header_repr.t;
    }
      -> Kind.double_baking_evidence contents
  | Activate_account : {
      id : Ed25519.Public_key_hash.t;
      activation_code : Blinded_public_key_hash.activation_code;
    }
      -> Kind.activate_account contents
  | Proposals : {
      source : Signature.Public_key_hash.t;
      period : Voting_period_repr.t;
      proposals : Protocol_hash.t list;
    }
      -> Kind.proposals contents
  | Ballot : {
      source : Signature.Public_key_hash.t;
      period : Voting_period_repr.t;
      proposal : Protocol_hash.t;
      ballot : Vote_repr.ballot;
    }
      -> Kind.ballot contents
  | Manager_operation : {
      source : Signature.public_key_hash;
      fee : Tez_repr.tez;
      counter : counter;
      operation : 'kind manager_operation;
      gas_limit : Z.t;
      storage_limit : Z.t;
    }
      -> 'kind Kind.manager contents

and _ manager_operation =
  | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation
  | Transaction : {
      amount : Tez_repr.tez;
      parameters : Script_repr.lazy_expr;
      entrypoint : string;
      destination : Contract_repr.contract;
    }
      -> Kind.transaction manager_operation
  | Origination : {
      delegate : Signature.Public_key_hash.t option;
      script : Script_repr.t;
      credit : Tez_repr.tez;
      preorigination : Contract_repr.t option;
    }
      -> Kind.origination manager_operation
  | Delegation :
      Signature.Public_key_hash.t option
      -> Kind.delegation manager_operation

and counter = Z.t

let manager_kind : type kind. kind manager_operation -> kind Kind.manager =
  function
  | Reveal _ ->
      Kind.Reveal_manager_kind
  | Transaction _ ->
      Kind.Transaction_manager_kind
  | Origination _ ->
      Kind.Origination_manager_kind
  | Delegation _ ->
      Kind.Delegation_manager_kind

type 'kind internal_operation = {
  source : Contract_repr.contract;
  operation : 'kind manager_operation;
  nonce : int;
}

type packed_manager_operation =
  | Manager : 'kind manager_operation -> packed_manager_operation

type packed_contents = Contents : 'kind contents -> packed_contents

type packed_contents_list =
  | Contents_list : 'kind contents_list -> packed_contents_list

type packed_protocol_data =
  | Operation_data : 'kind protocol_data -> packed_protocol_data

type packed_operation = {
  shell : Operation.shell_header;
  protocol_data : packed_protocol_data;
}

let pack ({shell; protocol_data} : _ operation) : packed_operation =
  {shell; protocol_data = Operation_data protocol_data}

type packed_internal_operation =
  | Internal_operation : 'kind internal_operation -> packed_internal_operation

let rec to_list = function
  | Contents_list (Single o) ->
      [Contents o]
  | Contents_list (Cons (o, os)) ->
      Contents o :: to_list (Contents_list os)

let rec of_list = function
  | [] ->
      assert false
  | [Contents o] ->
      Contents_list (Single o)
  | Contents o :: os -> (
      let (Contents_list os) = of_list os in
      match (o, os) with
      | (Manager_operation _, Single (Manager_operation _)) ->
          Contents_list (Cons (o, os))
      | (Manager_operation _, Cons _) ->
          Contents_list (Cons (o, os))
      | _ ->
          Pervasives.failwith
            "Operation list of length > 1 should only contains manager \
             operations." )

module Encoding = struct
  open Data_encoding

  let case tag name args proj inj =
    let open Data_encoding in
    case
      tag
      ~title:(String.capitalize_ascii name)
      (merge_objs (obj1 (req "kind" (constant name))) args)
      (fun x -> match proj x with None -> None | Some x -> Some ((), x))
      (fun ((), x) -> inj x)

  module Manager_operations = struct
    type 'kind case =
      | MCase : {
          tag : int;
          name : string;
          encoding : 'a Data_encoding.t;
          select : packed_manager_operation -> 'kind manager_operation option;
          proj : 'kind manager_operation -> 'a;
          inj : 'a -> 'kind manager_operation;
        }
          -> 'kind case

    let reveal_case =
      MCase
        {
          tag = 0;
          name = "reveal";
          encoding = obj1 (req "public_key" Signature.Public_key.encoding);
          select = (function Manager (Reveal _ as op) -> Some op | _ -> None);
          proj = (function Reveal pkh -> pkh);
          inj = (fun pkh -> Reveal pkh);
        }

    let entrypoint_encoding =
      def
        ~title:"entrypoint"
        ~description:"Named entrypoint to a Michelson smart contract"
        "entrypoint"
      @@
      let builtin_case tag name =
        Data_encoding.case
          (Tag tag)
          ~title:name
          (constant name)
          (fun n -> if Compare.String.(n = name) then Some () else None)
          (fun () -> name)
      in
      union
        [ builtin_case 0 "default";
          builtin_case 1 "root";
          builtin_case 2 "do";
          builtin_case 3 "set_delegate";
          builtin_case 4 "remove_delegate";
          Data_encoding.case
            (Tag 255)
            ~title:"named"
            (Bounded.string 31)
            (fun s -> Some s)
            (fun s -> s) ]

    let transaction_case =
      MCase
        {
          tag = 1;
          name = "transaction";
          encoding =
            obj3
              (req "amount" Tez_repr.encoding)
              (req "destination" Contract_repr.encoding)
              (opt
                 "parameters"
                 (obj2
                    (req "entrypoint" entrypoint_encoding)
                    (req "value" Script_repr.lazy_expr_encoding)));
          select =
            (function Manager (Transaction _ as op) -> Some op | _ -> None);
          proj =
            (function
            | Transaction {amount; destination; parameters; entrypoint} ->
                let parameters =
                  if
                    Script_repr.is_unit_parameter parameters
                    && Compare.String.(entrypoint = "default")
                  then None
                  else Some (entrypoint, parameters)
                in
                (amount, destination, parameters));
          inj =
            (fun (amount, destination, parameters) ->
              let (entrypoint, parameters) =
                match parameters with
                | None ->
                    ("default", Script_repr.unit_parameter)
                | Some (entrypoint, value) ->
                    (entrypoint, value)
              in
              Transaction {amount; destination; parameters; entrypoint});
        }

    let origination_case =
      MCase
        {
          tag = 2;
          name = "origination";
          encoding =
            obj3
              (req "balance" Tez_repr.encoding)
              (opt "delegate" Signature.Public_key_hash.encoding)
              (req "script" Script_repr.encoding);
          select =
            (function Manager (Origination _ as op) -> Some op | _ -> None);
          proj =
            (function
            | Origination
                { credit;
                  delegate;
                  script;
                  preorigination =
                    _
                    (* the hash is only used internally
                               when originating from smart
                               contracts, don't serialize it *)
                } ->
                (credit, delegate, script));
          inj =
            (fun (credit, delegate, script) ->
              Origination {credit; delegate; script; preorigination = None});
        }

    let delegation_case =
      MCase
        {
          tag = 3;
          name = "delegation";
          encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding);
          select =
            (function Manager (Delegation _ as op) -> Some op | _ -> None);
          proj = (function Delegation key -> key);
          inj = (fun key -> Delegation key);
        }

    let encoding =
      let make (MCase {tag; name; encoding; select; proj; inj}) =
        case
          (Tag tag)
          name
          encoding
          (fun o ->
            match select o with None -> None | Some o -> Some (proj o))
          (fun x -> Manager (inj x))
      in
      union
        ~tag_size:`Uint8
        [ make reveal_case;
          make transaction_case;
          make origination_case;
          make delegation_case ]
  end

  type 'b case =
    | Case : {
        tag : int;
        name : string;
        encoding : 'a Data_encoding.t;
        select : packed_contents -> 'b contents option;
        proj : 'b contents -> 'a;
        inj : 'a -> 'b contents;
      }
        -> 'b case

  let endorsement_encoding = obj1 (req "level" Raw_level_repr.encoding)

  let endorsement_case =
    Case
      {
        tag = 0;
        name = "endorsement";
        encoding = endorsement_encoding;
        select =
          (function Contents (Endorsement _ as op) -> Some op | _ -> None);
        proj = (fun (Endorsement {level}) -> level);
        inj = (fun level -> Endorsement {level});
      }

  let endorsement_encoding =
    let make (Case {tag; name; encoding; select = _; proj; inj}) =
      case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x)
    in
    let to_list : Kind.endorsement contents_list -> _ = function
      | Single o ->
          o
    in
    let of_list : Kind.endorsement contents -> _ = function o -> Single o in
    def "inlined.endorsement"
    @@ conv
         (fun ({shell; protocol_data = {contents; signature}} : _ operation) ->
           (shell, (contents, signature)))
         (fun (shell, (contents, signature)) ->
           ({shell; protocol_data = {contents; signature}} : _ operation))
         (merge_objs
            Operation.shell_header_encoding
            (obj2
               (req
                  "operations"
                  ( conv to_list of_list
                  @@ def "inlined.endorsement.contents"
                  @@ union [make endorsement_case] ))
               (varopt "signature" Signature.encoding)))

  let seed_nonce_revelation_case =
    Case
      {
        tag = 1;
        name = "seed_nonce_revelation";
        encoding =
          obj2
            (req "level" Raw_level_repr.encoding)
            (req "nonce" Seed_repr.nonce_encoding);
        select =
          (function
          | Contents (Seed_nonce_revelation _ as op) -> Some op | _ -> None);
        proj = (fun (Seed_nonce_revelation {level; nonce}) -> (level, nonce));
        inj = (fun (level, nonce) -> Seed_nonce_revelation {level; nonce});
      }

  let double_endorsement_evidence_case : Kind.double_endorsement_evidence case
      =
    Case
      {
        tag = 2;
        name = "double_endorsement_evidence";
        encoding =
          obj2
            (req "op1" (dynamic_size endorsement_encoding))
            (req "op2" (dynamic_size endorsement_encoding));
        select =
          (function
          | Contents (Double_endorsement_evidence _ as op) ->
              Some op
          | _ ->
              None);
        proj = (fun (Double_endorsement_evidence {op1; op2}) -> (op1, op2));
        inj = (fun (op1, op2) -> Double_endorsement_evidence {op1; op2});
      }

  let double_baking_evidence_case =
    Case
      {
        tag = 3;
        name = "double_baking_evidence";
        encoding =
          obj2
            (req "bh1" (dynamic_size Block_header_repr.encoding))
            (req "bh2" (dynamic_size Block_header_repr.encoding));
        select =
          (function
          | Contents (Double_baking_evidence _ as op) -> Some op | _ -> None);
        proj = (fun (Double_baking_evidence {bh1; bh2}) -> (bh1, bh2));
        inj = (fun (bh1, bh2) -> Double_baking_evidence {bh1; bh2});
      }

  let activate_account_case =
    Case
      {
        tag = 4;
        name = "activate_account";
        encoding =
          obj2
            (req "pkh" Ed25519.Public_key_hash.encoding)
            (req "secret" Blinded_public_key_hash.activation_code_encoding);
        select =
          (function
          | Contents (Activate_account _ as op) -> Some op | _ -> None);
        proj =
          (fun (Activate_account {id; activation_code}) ->
            (id, activation_code));
        inj =
          (fun (id, activation_code) -> Activate_account {id; activation_code});
      }

  let proposals_case =
    Case
      {
        tag = 5;
        name = "proposals";
        encoding =
          obj3
            (req "source" Signature.Public_key_hash.encoding)
            (req "period" Voting_period_repr.encoding)
            (req "proposals" (list Protocol_hash.encoding));
        select =
          (function Contents (Proposals _ as op) -> Some op | _ -> None);
        proj =
          (fun (Proposals {source; period; proposals}) ->
            (source, period, proposals));
        inj =
          (fun (source, period, proposals) ->
            Proposals {source; period; proposals});
      }

  let ballot_case =
    Case
      {
        tag = 6;
        name = "ballot";
        encoding =
          obj4
            (req "source" Signature.Public_key_hash.encoding)
            (req "period" Voting_period_repr.encoding)
            (req "proposal" Protocol_hash.encoding)
            (req "ballot" Vote_repr.ballot_encoding);
        select = (function Contents (Ballot _ as op) -> Some op | _ -> None);
        proj =
          (function
          | Ballot {source; period; proposal; ballot} ->
              (source, period, proposal, ballot));
        inj =
          (fun (source, period, proposal, ballot) ->
            Ballot {source; period; proposal; ballot});
      }

  let manager_encoding =
    obj5
      (req "source" Signature.Public_key_hash.encoding)
      (req "fee" Tez_repr.encoding)
      (req "counter" (check_size 10 n))
      (req "gas_limit" (check_size 10 n))
      (req "storage_limit" (check_size 10 n))

  let extract (type kind)
      (Manager_operation
         {source; fee; counter; gas_limit; storage_limit; operation = _} :
        kind Kind.manager contents) =
    (source, fee, counter, gas_limit, storage_limit)

  let rebuild (source, fee, counter, gas_limit, storage_limit) operation =
    Manager_operation
      {source; fee; counter; gas_limit; storage_limit; operation}

  let make_manager_case tag (type kind)
      (Manager_operations.MCase mcase : kind Manager_operations.case) =
    Case
      {
        tag;
        name = mcase.name;
        encoding = merge_objs manager_encoding mcase.encoding;
        select =
          (function
          | Contents (Manager_operation ({operation; _} as op)) -> (
            match mcase.select (Manager operation) with
            | None ->
                None
            | Some operation ->
                Some (Manager_operation {op with operation}) )
          | _ ->
              None);
        proj =
          (function
          | Manager_operation {operation; _} as op ->
              (extract op, mcase.proj operation));
        inj = (fun (op, contents) -> rebuild op (mcase.inj contents));
      }

  let reveal_case = make_manager_case 107 Manager_operations.reveal_case

  let transaction_case =
    make_manager_case 108 Manager_operations.transaction_case

  let origination_case =
    make_manager_case 109 Manager_operations.origination_case

  let delegation_case =
    make_manager_case 110 Manager_operations.delegation_case

  let contents_encoding =
    let make (Case {tag; name; encoding; select; proj; inj}) =
      case
        (Tag tag)
        name
        encoding
        (fun o -> match select o with None -> None | Some o -> Some (proj o))
        (fun x -> Contents (inj x))
    in
    def "operation.alpha.contents"
    @@ union
         [ make endorsement_case;
           make seed_nonce_revelation_case;
           make double_endorsement_evidence_case;
           make double_baking_evidence_case;
           make activate_account_case;
           make proposals_case;
           make ballot_case;
           make reveal_case;
           make transaction_case;
           make origination_case;
           make delegation_case ]

  let contents_list_encoding =
    conv to_list of_list (Variable.list contents_encoding)

  let optional_signature_encoding =
    conv
      (function Some s -> s | None -> Signature.zero)
      (fun s -> if Signature.equal s Signature.zero then None else Some s)
      Signature.encoding

  let protocol_data_encoding =
    def "operation.alpha.contents_and_signature"
    @@ conv
         (fun (Operation_data {contents; signature}) ->
           (Contents_list contents, signature))
         (fun (Contents_list contents, signature) ->
           Operation_data {contents; signature})
         (obj2
            (req "contents" contents_list_encoding)
            (req "signature" optional_signature_encoding))

  let operation_encoding =
    conv
      (fun {shell; protocol_data} -> (shell, protocol_data))
      (fun (shell, protocol_data) -> {shell; protocol_data})
      (merge_objs Operation.shell_header_encoding protocol_data_encoding)

  let unsigned_operation_encoding =
    def "operation.alpha.unsigned_operation"
    @@ merge_objs
         Operation.shell_header_encoding
         (obj1 (req "contents" contents_list_encoding))

  let internal_operation_encoding =
    def "operation.alpha.internal_operation"
    @@ conv
         (fun (Internal_operation {source; operation; nonce}) ->
           ((source, nonce), Manager operation))
         (fun ((source, nonce), Manager operation) ->
           Internal_operation {source; operation; nonce})
         (merge_objs
            (obj2 (req "source" Contract_repr.encoding) (req "nonce" uint16))
            Manager_operations.encoding)
end

let encoding = Encoding.operation_encoding

let contents_encoding = Encoding.contents_encoding

let contents_list_encoding = Encoding.contents_list_encoding

let protocol_data_encoding = Encoding.protocol_data_encoding

let unsigned_operation_encoding = Encoding.unsigned_operation_encoding

let internal_operation_encoding = Encoding.internal_operation_encoding

let raw ({shell; protocol_data} : _ operation) =
  let proto =
    Data_encoding.Binary.to_bytes_exn
      protocol_data_encoding
      (Operation_data protocol_data)
  in
  {Operation.shell; proto}

let acceptable_passes (op : packed_operation) =
  let (Operation_data protocol_data) = op.protocol_data in
  match protocol_data.contents with
  | Single (Endorsement _) ->
      [0]
  | Single (Proposals _) ->
      [1]
  | Single (Ballot _) ->
      [1]
  | Single (Seed_nonce_revelation _) ->
      [2]
  | Single (Double_endorsement_evidence _) ->
      [2]
  | Single (Double_baking_evidence _) ->
      [2]
  | Single (Activate_account _) ->
      [2]
  | Single (Manager_operation _) ->
      [3]
  | Cons _ ->
      [3]

type error += Invalid_signature (* `Permanent *)

type error += Missing_signature (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"operation.invalid_signature"
    ~title:"Invalid operation signature"
    ~description:
      "The operation signature is ill-formed or has been made with the wrong \
       public key"
    ~pp:(fun ppf () -> Format.fprintf ppf "The operation signature is invalid")
    Data_encoding.unit
    (function Invalid_signature -> Some () | _ -> None)
    (fun () -> Invalid_signature) ;
  register_error_kind
    `Permanent
    ~id:"operation.missing_signature"
    ~title:"Missing operation signature"
    ~description:
      "The operation is of a kind that must be signed, but the signature is \
       missing"
    ~pp:(fun ppf () -> Format.fprintf ppf "The operation requires a signature")
    Data_encoding.unit
    (function Missing_signature -> Some () | _ -> None)
    (fun () -> Missing_signature)

let check_signature_sync (type kind) key chain_id
    ({shell; protocol_data} : kind operation) =
  let check ~watermark contents signature =
    let unsigned_operation =
      Data_encoding.Binary.to_bytes_exn
        unsigned_operation_encoding
        (shell, contents)
    in
    if Signature.check ~watermark key signature unsigned_operation then Ok ()
    else error Invalid_signature
  in
  match (protocol_data.contents, protocol_data.signature) with
  | (Single _, None) ->
      error Missing_signature
  | (Cons _, None) ->
      error Missing_signature
  | ((Single (Endorsement _) as contents), Some signature) ->
      check
        ~watermark:(Endorsement chain_id)
        (Contents_list contents)
        signature
  | ((Single _ as contents), Some signature) ->
      check ~watermark:Generic_operation (Contents_list contents) signature
  | ((Cons _ as contents), Some signature) ->
      check ~watermark:Generic_operation (Contents_list contents) signature

let check_signature pk chain_id op =
  Lwt.return (check_signature_sync pk chain_id op)

let hash_raw = Operation.hash

let hash (o : _ operation) =
  let proto =
    Data_encoding.Binary.to_bytes_exn
      protocol_data_encoding
      (Operation_data o.protocol_data)
  in
  Operation.hash {shell = o.shell; proto}

let hash_packed (o : packed_operation) =
  let proto =
    Data_encoding.Binary.to_bytes_exn protocol_data_encoding o.protocol_data
  in
  Operation.hash {shell = o.shell; proto}

type ('a, 'b) eq = Eq : ('a, 'a) eq

let equal_manager_operation_kind :
    type a b. a manager_operation -> b manager_operation -> (a, b) eq option =
 fun op1 op2 ->
  match (op1, op2) with
  | (Reveal _, Reveal _) ->
      Some Eq
  | (Reveal _, _) ->
      None
  | (Transaction _, Transaction _) ->
      Some Eq
  | (Transaction _, _) ->
      None
  | (Origination _, Origination _) ->
      Some Eq
  | (Origination _, _) ->
      None
  | (Delegation _, Delegation _) ->
      Some Eq
  | (Delegation _, _) ->
      None

let equal_contents_kind :
    type a b. a contents -> b contents -> (a, b) eq option =
 fun op1 op2 ->
  match (op1, op2) with
  | (Endorsement _, Endorsement _) ->
      Some Eq
  | (Endorsement _, _) ->
      None
  | (Seed_nonce_revelation _, Seed_nonce_revelation _) ->
      Some Eq
  | (Seed_nonce_revelation _, _) ->
      None
  | (Double_endorsement_evidence _, Double_endorsement_evidence _) ->
      Some Eq
  | (Double_endorsement_evidence _, _) ->
      None
  | (Double_baking_evidence _, Double_baking_evidence _) ->
      Some Eq
  | (Double_baking_evidence _, _) ->
      None
  | (Activate_account _, Activate_account _) ->
      Some Eq
  | (Activate_account _, _) ->
      None
  | (Proposals _, Proposals _) ->
      Some Eq
  | (Proposals _, _) ->
      None
  | (Ballot _, Ballot _) ->
      Some Eq
  | (Ballot _, _) ->
      None
  | (Manager_operation op1, Manager_operation op2) -> (
    match equal_manager_operation_kind op1.operation op2.operation with
    | None ->
        None
    | Some Eq ->
        Some Eq )
  | (Manager_operation _, _) ->
      None

let rec equal_contents_kind_list :
    type a b. a contents_list -> b contents_list -> (a, b) eq option =
 fun op1 op2 ->
  match (op1, op2) with
  | (Single op1, Single op2) ->
      equal_contents_kind op1 op2
  | (Single _, Cons _) ->
      None
  | (Cons _, Single _) ->
      None
  | (Cons (op1, ops1), Cons (op2, ops2)) -> (
    match equal_contents_kind op1 op2 with
    | None ->
        None
    | Some Eq -> (
      match equal_contents_kind_list ops1 ops2 with
      | None ->
          None
      | Some Eq ->
          Some Eq ) )

let equal : type a b. a operation -> b operation -> (a, b) eq option =
 fun op1 op2 ->
  if not (Operation_hash.equal (hash op1) (hash op2)) then None
  else
    equal_contents_kind_list
      op1.protocol_data.contents
      op2.protocol_data.contents
Operation_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Blinded_public_key_hash.
Require Tezos.Block_header_repr.
Require Tezos.Contract_repr.
Require Tezos.Raw_level_repr.
Require Tezos.Script_repr.
Require Tezos.Seed_repr.
Require Tezos.Tez_repr.
Require Tezos.Vote_repr.
Require Tezos.Voting_period_repr.

Module Kind.
  Inductive seed_nonce_revelation : Set :=
  | Seed_nonce_revelation_kind : seed_nonce_revelation.
  
  Inductive double_endorsement_evidence : Set :=
  | Double_endorsement_evidence_kind : double_endorsement_evidence.
  
  Inductive double_baking_evidence : Set :=
  | Double_baking_evidence_kind : double_baking_evidence.
  
  Inductive activate_account : Set :=
  | Activate_account_kind : activate_account.
  
  Inductive endorsement : Set :=
  | Endorsement_kind : endorsement.
  
  Inductive proposals : Set :=
  | Proposals_kind : proposals.
  
  Inductive ballot : Set :=
  | Ballot_kind : ballot.
  
  Inductive reveal : Set :=
  | Reveal_kind : reveal.
  
  Inductive transaction : Set :=
  | Transaction_kind : transaction.
  
  Inductive origination : Set :=
  | Origination_kind : origination.
  
  Inductive delegation : Set :=
  | Delegation_kind : delegation.
  
  Reserved Notation "'manager".
  
  Inductive manager_gadt : Set :=
  | Reveal_manager_kind : manager_gadt
  | Transaction_manager_kind : manager_gadt
  | Origination_manager_kind : manager_gadt
  | Delegation_manager_kind : manager_gadt
  
  where "'manager" := (fun (_ : Set) => manager_gadt).
  
  Definition manager := 'manager.
End Kind.

Module raw.
  Record record := Build {
    shell : Operation.shell_header;
    proto : MBytes.t }.
  Definition with_shell shell (r : record) :=
    Build shell r.(proto).
  Definition with_proto proto (r : record) :=
    Build r.(shell) proto.
End raw.
Definition raw := raw.record.

Definition raw_encoding : Data_encoding.t Operation.t := Operation.encoding.

Module contents.
  Module Endorsement.
    Record record {level : Set} := {
      level : level }.
    Arguments record : clear implicits.
  End Endorsement.
  Definition Endorsement_skeleton := Endorsement.record.
  
  Module Seed_nonce_revelation.
    Record record {level nonce : Set} := {
      level : level;
      nonce : nonce }.
    Arguments record : clear implicits.
  End Seed_nonce_revelation.
  Definition Seed_nonce_revelation_skeleton := Seed_nonce_revelation.record.
  
  Module Double_endorsement_evidence.
    Record record {op1 op2 : Set} := {
      op1 : op1;
      op2 : op2 }.
    Arguments record : clear implicits.
  End Double_endorsement_evidence.
  Definition Double_endorsement_evidence_skeleton :=
    Double_endorsement_evidence.record.
  
  Module Double_baking_evidence.
    Record record {bh1 bh2 : Set} := {
      bh1 : bh1;
      bh2 : bh2 }.
    Arguments record : clear implicits.
  End Double_baking_evidence.
  Definition Double_baking_evidence_skeleton := Double_baking_evidence.record.
  
  Module Activate_account.
    Record record {id activation_code : Set} := {
      id : id;
      activation_code : activation_code }.
    Arguments record : clear implicits.
  End Activate_account.
  Definition Activate_account_skeleton := Activate_account.record.
  
  Module Proposals.
    Record record {source period proposals : Set} := {
      source : source;
      period : period;
      proposals : proposals }.
    Arguments record : clear implicits.
  End Proposals.
  Definition Proposals_skeleton := Proposals.record.
  
  Module Ballot.
    Record record {source period proposal ballot : Set} := {
      source : source;
      period : period;
      proposal : proposal;
      ballot : ballot }.
    Arguments record : clear implicits.
  End Ballot.
  Definition Ballot_skeleton := Ballot.record.
  
  Module Manager_operation.
    Record record {source fee counter operation gas_limit storage_limit : Set} := {
      source : source;
      fee : fee;
      counter : counter;
      operation : operation;
      gas_limit : gas_limit;
      storage_limit : storage_limit }.
    Arguments record : clear implicits.
  End Manager_operation.
  Definition Manager_operation_skeleton := Manager_operation.record.
End contents.

Module manager_operation.
  Module Transaction.
    Record record {amount parameters entrypoint destination : Set} := {
      amount : amount;
      parameters : parameters;
      entrypoint : entrypoint;
      destination : destination }.
    Arguments record : clear implicits.
  End Transaction.
  Definition Transaction_skeleton := Transaction.record.
  
  Module Origination.
    Record record {delegate script credit preorigination : Set} := {
      delegate : delegate;
      script : script;
      credit : credit;
      preorigination : preorigination }.
    Arguments record : clear implicits.
  End Origination.
  Definition Origination_skeleton := Origination.record.
End manager_operation.

Module protocol_data.
  Record record {contents signature : Set} := Build {
    contents : contents;
    signature : signature }.
  Arguments record : clear implicits.
  Definition with_contents {t_contents t_signature} contents
    (r : record t_contents t_signature) :=
    Build t_contents t_signature contents r.(signature).
  Definition with_signature {t_contents t_signature} signature
    (r : record t_contents t_signature) :=
    Build t_contents t_signature r.(contents) signature.
End protocol_data.
Definition protocol_data_skeleton := protocol_data.record.

Module operation.
  Record record {shell protocol_data : Set} := Build {
    shell : shell;
    protocol_data : protocol_data }.
  Arguments record : clear implicits.
  Definition with_shell {t_shell t_protocol_data} shell
    (r : record t_shell t_protocol_data) :=
    Build t_shell t_protocol_data shell r.(protocol_data).
  Definition with_protocol_data {t_shell t_protocol_data} protocol_data
    (r : record t_shell t_protocol_data) :=
    Build t_shell t_protocol_data r.(shell) protocol_data.
End operation.
Definition operation_skeleton := operation.record.

Reserved Notation "'contents.Endorsement".
Reserved Notation "'contents.Seed_nonce_revelation".
Reserved Notation "'contents.Double_endorsement_evidence".
Reserved Notation "'contents.Double_baking_evidence".
Reserved Notation "'contents.Activate_account".
Reserved Notation "'contents.Proposals".
Reserved Notation "'contents.Ballot".
Reserved Notation "'contents.Manager_operation".
Reserved Notation "'manager_operation.Transaction".
Reserved Notation "'manager_operation.Origination".
Reserved Notation "'operation".
Reserved Notation "'protocol_data".
Reserved Notation "'contents_list".
Reserved Notation "'contents".
Reserved Notation "'manager_operation".
Reserved Notation "'counter".

Inductive contents_list_gadt : Set :=
| Single : forall {kind : Set}, 'contents kind -> contents_list_gadt
| Cons : forall {kind : Set},
  'contents (Kind.manager kind) -> contents_list_gadt -> contents_list_gadt

with contents_gadt : Set :=
| Endorsement : 'contents.Endorsement -> contents_gadt
| Seed_nonce_revelation : 'contents.Seed_nonce_revelation -> contents_gadt
| Double_endorsement_evidence :
  'contents.Double_endorsement_evidence -> contents_gadt
| Double_baking_evidence : 'contents.Double_baking_evidence -> contents_gadt
| Activate_account : 'contents.Activate_account -> contents_gadt
| Proposals : 'contents.Proposals -> contents_gadt
| Ballot : 'contents.Ballot -> contents_gadt
| Manager_operation : forall {kind : Set},
  'contents.Manager_operation kind -> contents_gadt

with manager_operation_gadt : Set :=
| Reveal : (|Signature.Public_key|).(S.SPublic_key.t) -> manager_operation_gadt
| Transaction : 'manager_operation.Transaction -> manager_operation_gadt
| Origination : 'manager_operation.Origination -> manager_operation_gadt
| Delegation :
  option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  manager_operation_gadt

where "'operation" := (fun (t_kind : Set) =>
  operation_skeleton Operation.shell_header ('protocol_data t_kind))
and "'protocol_data" := (fun (t_kind : Set) =>
  protocol_data_skeleton ('contents_list t_kind) (option Signature.t))
and "'contents_list" := (fun (_ : Set) => contents_list_gadt)
and "'contents" := (fun (_ : Set) => contents_gadt)
and "'manager_operation" := (fun (_ : Set) => manager_operation_gadt)
and "'counter" := (Z.t)
and "'contents.Endorsement" := (contents.Endorsement_skeleton Raw_level_repr.t)
and "'contents.Seed_nonce_revelation" :=
  (contents.Seed_nonce_revelation_skeleton Raw_level_repr.t Seed_repr.nonce)
and "'contents.Double_endorsement_evidence" :=
  (contents.Double_endorsement_evidence_skeleton ('operation Kind.endorsement)
    ('operation Kind.endorsement))
and "'contents.Double_baking_evidence" :=
  (contents.Double_baking_evidence_skeleton Block_header_repr.t
    Block_header_repr.t)
and "'contents.Activate_account" :=
  (contents.Activate_account_skeleton
    (|Ed25519|).(S.SIGNATURE.Public_key_hash).(S.SPublic_key_hash.t)
    Blinded_public_key_hash.activation_code)
and "'contents.Proposals" :=
  (contents.Proposals_skeleton
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) Voting_period_repr.t
    (list (|Protocol_hash|).(S.HASH.t)))
and "'contents.Ballot" :=
  (contents.Ballot_skeleton (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)
    Voting_period_repr.t (|Protocol_hash|).(S.HASH.t) Vote_repr.ballot)
and "'contents.Manager_operation" := (fun (t_kind : Set) =>
  contents.Manager_operation_skeleton Signature.public_key_hash Tez_repr.tez
    'counter ('manager_operation t_kind) Z.t Z.t)
and "'manager_operation.Transaction" :=
  (manager_operation.Transaction_skeleton Tez_repr.tez Script_repr.lazy_expr
    string Contract_repr.contract)
and "'manager_operation.Origination" :=
  (manager_operation.Origination_skeleton
    (option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) Script_repr.t
    Tez_repr.tez (option Contract_repr.t)).

Module
  ConstructorRecordNotations_contents_list_gadt_contents_gadt_manager_operation_gadt.
  Module contents.
    Definition Endorsement := 'contents.Endorsement.
    Definition Seed_nonce_revelation := 'contents.Seed_nonce_revelation.
    Definition Double_endorsement_evidence :=
      'contents.Double_endorsement_evidence.
    Definition Double_baking_evidence := 'contents.Double_baking_evidence.
    Definition Activate_account := 'contents.Activate_account.
    Definition Proposals := 'contents.Proposals.
    Definition Ballot := 'contents.Ballot.
    Definition Manager_operation := 'contents.Manager_operation.
  End contents.
  Module manager_operation.
    Definition Transaction := 'manager_operation.Transaction.
    Definition Origination := 'manager_operation.Origination.
  End manager_operation.
End
  ConstructorRecordNotations_contents_list_gadt_contents_gadt_manager_operation_gadt.
Import
  ConstructorRecordNotations_contents_list_gadt_contents_gadt_manager_operation_gadt.

Definition operation := 'operation.
Definition protocol_data := 'protocol_data.
Definition contents_list := 'contents_list.
Definition contents := 'contents.
Definition manager_operation := 'manager_operation.
Definition counter := 'counter.

Definition manager_kind {kind : Set}
  (function_parameter : manager_operation kind) : Kind.manager kind :=
  match function_parameter with
  | Reveal _ => Kind.Reveal_manager_kind
  | Transaction _ => Kind.Transaction_manager_kind
  | Origination _ => Kind.Origination_manager_kind
  | Delegation _ => Kind.Delegation_manager_kind
  end.

Module internal_operation.
  Record record {kind : Set} := Build {
    source : Contract_repr.contract;
    operation : manager_operation kind;
    nonce : Z }.
  Arguments record : clear implicits.
  Definition with_source {t_kind} source (r : record t_kind) :=
    Build t_kind source r.(operation) r.(nonce).
  Definition with_operation {t_kind} operation (r : record t_kind) :=
    Build t_kind r.(source) operation r.(nonce).
  Definition with_nonce {t_kind} nonce (r : record t_kind) :=
    Build t_kind r.(source) r.(operation) nonce.
End internal_operation.
Definition internal_operation := internal_operation.record.

Reserved Notation "'packed_manager_operation".

Inductive packed_manager_operation_gadt : Set :=
| Manager : forall {kind : Set},
  manager_operation kind -> packed_manager_operation_gadt

where "'packed_manager_operation" := (packed_manager_operation_gadt).

Definition packed_manager_operation := 'packed_manager_operation.

Reserved Notation "'packed_contents".

Inductive packed_contents_gadt : Set :=
| Contents : forall {kind : Set}, contents kind -> packed_contents_gadt

where "'packed_contents" := (packed_contents_gadt).

Definition packed_contents := 'packed_contents.

Reserved Notation "'packed_contents_list".

Inductive packed_contents_list_gadt : Set :=
| Contents_list : forall {kind : Set},
  contents_list kind -> packed_contents_list_gadt

where "'packed_contents_list" := (packed_contents_list_gadt).

Definition packed_contents_list := 'packed_contents_list.

Reserved Notation "'packed_protocol_data".

Inductive packed_protocol_data_gadt : Set :=
| Operation_data : forall {kind : Set},
  protocol_data kind -> packed_protocol_data_gadt

where "'packed_protocol_data" := (packed_protocol_data_gadt).

Definition packed_protocol_data := 'packed_protocol_data.

Module packed_operation.
  Record record := Build {
    shell : Operation.shell_header;
    protocol_data : packed_protocol_data }.
  Definition with_shell shell (r : record) :=
    Build shell r.(protocol_data).
  Definition with_protocol_data protocol_data (r : record) :=
    Build r.(shell) protocol_data.
End packed_operation.
Definition packed_operation := packed_operation.record.

Definition pack {A : Set} (function_parameter : operation A)
  : packed_operation :=
  let '{|
    operation.shell := shell; operation.protocol_data := protocol_data |} :=
    function_parameter in
  {| packed_operation.shell := shell;
    packed_operation.protocol_data := Operation_data protocol_data |}.

Reserved Notation "'packed_internal_operation".

Inductive packed_internal_operation_gadt : Set :=
| Internal_operation : forall {kind : Set},
  internal_operation kind -> packed_internal_operation_gadt

where "'packed_internal_operation" := (packed_internal_operation_gadt).

Definition packed_internal_operation := 'packed_internal_operation.

Fixpoint to_list (function_parameter : packed_contents_list)
  {struct function_parameter} : list packed_contents :=
  match function_parameter with
  | Contents_list (Single o) => [ Contents o ]
  | Contents_list (Cons o os) => cons (Contents o) (to_list (Contents_list os))
  end.

Fixpoint of_list (function_parameter : list packed_contents)
  {struct function_parameter} : packed_contents_list :=
  match function_parameter with
  | [] =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | cons (Contents o) [] => Contents_list (Single o)
  | cons (Contents o) os =>
    let 'Contents_list os := of_list os in
    match (o, os) with
    | (Manager_operation _, Single (Manager_operation _)) =>
      Contents_list (Cons o os)
    | (Manager_operation _, Cons _ _) => Contents_list (Cons o os)
    | _ =>
      Pervasives.failwith
        "Operation list of length > 1 should only contains manager operations."
    end
  end.

Module Encoding.
  Import Data_encoding.
  
  Definition __case_value {A B : Set}
    (tag : Data_encoding.case_tag) (name : string)
    (args : Data_encoding.encoding A) (proj : B -> option A) (inj : A -> B)
    : Data_encoding.case B :=
    Data_encoding.__case_value (String.capitalize_ascii name) None tag
      (Data_encoding.merge_objs
        (Data_encoding.obj1
          (Data_encoding.req None None "kind" (Data_encoding.constant name)))
        args)
      (fun x =>
        match proj x with
        | None => None
        | Some x => Some (tt, x)
        end)
      (fun function_parameter =>
        let '(_, x) := function_parameter in
        inj x).
  
  Module Manager_operations.
    Module case.
      Module MCase.
        Record record {tag name encoding select proj inj : Set} := {
          tag : tag;
          name : name;
          encoding : encoding;
          select : select;
          proj : proj;
          inj : inj }.
        Arguments record : clear implicits.
      End MCase.
      Definition MCase_skeleton := MCase.record.
    End case.
    
    Reserved Notation "'case.MCase".
    Reserved Notation "'case".
    
    Inductive case_gadt : Set :=
    | MCase : forall {a kind : Set}, 'case.MCase a kind -> case_gadt
    
    where "'case" := (fun (_ : Set) => case_gadt)
    and "'case.MCase" := (fun (t_a t_kind : Set) =>
      case.MCase_skeleton Z string (Data_encoding.t t_a)
        (packed_manager_operation -> option (manager_operation t_kind))
        (manager_operation t_kind -> t_a) (t_a -> manager_operation t_kind)).
    
    Module ConstructorRecordNotations_case_gadt.
      Module case.
        Definition MCase := 'case.MCase.
      End case.
    End ConstructorRecordNotations_case_gadt.
    Import ConstructorRecordNotations_case_gadt.
    
    Definition case := 'case.
    
    Definition reveal_case : case Kind.reveal :=
      MCase
        {| case.MCase.tag := 0; case.MCase.name := "reveal";
          case.MCase.encoding :=
            Data_encoding.obj1
              (Data_encoding.req None None "public_key"
                (|Signature.Public_key|).(S.SPublic_key.encoding));
          case.MCase.select :=
            fun function_parameter =>
              match function_parameter with
              | Manager ((Reveal _) as op) => Some op
              | _ => None
              end;
          case.MCase.proj :=
            fun function_parameter =>
              let 'Reveal pkh := function_parameter in
              pkh; case.MCase.inj := fun pkh => Reveal pkh |}.
    
    Definition entrypoint_encoding
      : Data_encoding.encoding (|Compare.String|).(Compare.S.t) :=
      Pervasives.op_atat
        (Data_encoding.def "entrypoint" (Some "entrypoint")
          (Some "Named entrypoint to a Michelson smart contract"))
        (let builtin_case (tag : Z) (name : (|Compare.String|).(Compare.S.t))
          : Data_encoding.case (|Compare.String|).(Compare.S.t) :=
          Data_encoding.__case_value name None (Data_encoding.Tag tag)
            (Data_encoding.constant name)
            (fun n =>
              if (|Compare.String|).(Compare.S.op_eq) n name then
                Some tt
              else
                None)
            (fun function_parameter =>
              let '_ := function_parameter in
              name) in
        Data_encoding.union None
          [
            builtin_case 0 "default";
            builtin_case 1 "root";
            builtin_case 2 "do";
            builtin_case 3 "set_delegate";
            builtin_case 4 "remove_delegate";
            Data_encoding.__case_value "named" None (Data_encoding.Tag 255)
              (Data_encoding.Bounded.__string_value 31)
              (fun s => Some s) (fun s => s)
          ]).
    
    Definition transaction_case : case Kind.transaction :=
      MCase
        {| case.MCase.tag := 1; case.MCase.name := "transaction";
          case.MCase.encoding :=
            Data_encoding.obj3
              (Data_encoding.req None None "amount" Tez_repr.encoding)
              (Data_encoding.req None None "destination" Contract_repr.encoding)
              (Data_encoding.opt None None "parameters"
                (Data_encoding.obj2
                  (Data_encoding.req None None "entrypoint" entrypoint_encoding)
                  (Data_encoding.req None None "value"
                    Script_repr.lazy_expr_encoding)));
          case.MCase.select :=
            fun function_parameter =>
              match function_parameter with
              | Manager ((Transaction _) as op) => Some op
              | _ => None
              end;
          case.MCase.proj :=
            fun function_parameter =>
              let
                'Transaction {|
                  manager_operation.Transaction.amount := amount;
                    manager_operation.Transaction.parameters := parameters;
                    manager_operation.Transaction.entrypoint := entrypoint;
                    manager_operation.Transaction.destination := destination
                    |} := function_parameter in
              let parameters :=
                if
                  Pervasives.op_andand
                    (Script_repr.is_unit_parameter parameters)
                    ((|Compare.String|).(Compare.S.op_eq) entrypoint "default")
                  then
                  None
                else
                  Some (entrypoint, parameters) in
              (amount, destination, parameters);
          case.MCase.inj :=
            fun function_parameter =>
              let '(amount, destination, parameters) := function_parameter in
              let '(entrypoint, parameters) :=
                match parameters with
                | None => ("default", Script_repr.unit_parameter)
                | Some (entrypoint, value) => (entrypoint, value)
                end in
              Transaction
                {| manager_operation.Transaction.amount := amount;
                  manager_operation.Transaction.parameters := parameters;
                  manager_operation.Transaction.entrypoint := entrypoint;
                  manager_operation.Transaction.destination := destination |} |}.
    
    Definition origination_case : case Kind.origination :=
      MCase
        {| case.MCase.tag := 2; case.MCase.name := "origination";
          case.MCase.encoding :=
            Data_encoding.obj3
              (Data_encoding.req None None "balance" Tez_repr.encoding)
              (Data_encoding.opt None None "delegate"
                (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding))
              (Data_encoding.req None None "script" Script_repr.encoding);
          case.MCase.select :=
            fun function_parameter =>
              match function_parameter with
              | Manager ((Origination _) as op) => Some op
              | _ => None
              end;
          case.MCase.proj :=
            fun function_parameter =>
              let
                'Origination {|
                  manager_operation.Origination.delegate := delegate;
                    manager_operation.Origination.script := script;
                    manager_operation.Origination.credit := credit;
                    manager_operation.Origination.preorigination := _
                    |} := function_parameter in
              (credit, delegate, script);
          case.MCase.inj :=
            fun function_parameter =>
              let '(credit, delegate, script) := function_parameter in
              Origination
                {| manager_operation.Origination.delegate := delegate;
                  manager_operation.Origination.script := script;
                  manager_operation.Origination.credit := credit;
                  manager_operation.Origination.preorigination := None |} |}.
    
    Definition delegation_case : case Kind.delegation :=
      MCase
        {| case.MCase.tag := 3; case.MCase.name := "delegation";
          case.MCase.encoding :=
            Data_encoding.obj1
              (Data_encoding.opt None None "delegate"
                (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding));
          case.MCase.select :=
            fun function_parameter =>
              match function_parameter with
              | Manager ((Delegation _) as op) => Some op
              | _ => None
              end;
          case.MCase.proj :=
            fun function_parameter =>
              let 'Delegation key := function_parameter in
              key; case.MCase.inj := fun key => Delegation key |}.
    
    Definition encoding : Data_encoding.encoding packed_manager_operation :=
      let make {A : Set} (function_parameter : case A)
        : Data_encoding.case packed_manager_operation :=
        let
          'MCase {|
            case.MCase.tag := tag;
              case.MCase.name := name;
              case.MCase.encoding := encoding;
              case.MCase.select := select;
              case.MCase.proj := proj;
              case.MCase.inj := inj
              |} := function_parameter in
        __case_value (Data_encoding.Tag tag) name encoding
          (fun o =>
            match select o with
            | None => None
            | Some o => Some (proj o)
            end) (fun x => Manager (inj x)) in
      Data_encoding.union
        (Some
          (* ❌ Variants not supported *)
          (* ❌ `Uint8 *)
          Data_encoding.Uint8)
        [
          make reveal_case;
          make transaction_case;
          make origination_case;
          make delegation_case
        ].
  End Manager_operations.
  
  Module case.
    Module Case.
      Record record {tag name encoding select proj inj : Set} := {
        tag : tag;
        name : name;
        encoding : encoding;
        select : select;
        proj : proj;
        inj : inj }.
      Arguments record : clear implicits.
    End Case.
    Definition Case_skeleton := Case.record.
  End case.
  
  Reserved Notation "'case.Case".
  Reserved Notation "'case".
  
  Inductive case_gadt : Set :=
  | Case : forall {a b : Set}, 'case.Case a b -> case_gadt
  
  where "'case" := (fun (_ : Set) => case_gadt)
  and "'case.Case" := (fun (t_a t_b : Set) =>
    case.Case_skeleton Z string (Data_encoding.t t_a)
      (packed_contents -> option (contents t_b)) (contents t_b -> t_a)
      (t_a -> contents t_b)).
  
  Module ConstructorRecordNotations_case_gadt.
    Module case.
      Definition Case := 'case.Case.
    End case.
  End ConstructorRecordNotations_case_gadt.
  Import ConstructorRecordNotations_case_gadt.
  
  Definition case := 'case.
  
  Definition endorsement_encoding
    : Data_encoding.encoding Raw_level_repr.raw_level :=
    Data_encoding.obj1
      (Data_encoding.req None None "level" Raw_level_repr.encoding).
  
  Definition endorsement_case : case Kind.endorsement :=
    Case
      {| case.Case.tag := 0; case.Case.name := "endorsement";
        case.Case.encoding := endorsement_encoding;
        case.Case.select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Endorsement _) as op) => Some op
            | _ => None
            end;
        case.Case.proj :=
          fun function_parameter =>
            let 'Endorsement {| contents.Endorsement.level := level |} :=
              function_parameter in
            level;
        case.Case.inj :=
          fun level => Endorsement {| contents.Endorsement.level := level |} |}.
  
  Definition endorsement_encoding
    : Data_encoding.encoding (operation Kind.endorsement) :=
    let make {A : Set} (function_parameter : case A)
      : Data_encoding.case (contents A) :=
      let
        'Case {|
          case.Case.tag := tag;
            case.Case.name := name;
            case.Case.encoding := encoding;
            case.Case.select := _;
            case.Case.proj := proj;
            case.Case.inj := inj
            |} := function_parameter in
      __case_value (Data_encoding.Tag tag) name encoding
        (fun o => Some (proj o)) (fun x => inj x) in
    let to_list (function_parameter : contents_list Kind.endorsement)
      : contents Kind.endorsement :=
      let 'Single o := function_parameter in
      o in
    let of_list (o : contents Kind.endorsement)
      : contents_list Kind.endorsement :=
      Single o in
    Pervasives.op_atat
      (let arg := Data_encoding.def "inlined.endorsement" in
      fun eta => arg None None eta)
      (Data_encoding.conv
        (fun function_parameter =>
          let '{|
            operation.shell := shell;
              operation.protocol_data := {|
                protocol_data.contents := contents;
                  protocol_data.signature := signature
                  |}
              |} := function_parameter in
          (shell, (contents, signature)))
        (fun function_parameter =>
          let '(shell, (contents, signature)) := function_parameter in
          {| operation.shell := shell;
            operation.protocol_data :=
              {| protocol_data.contents := contents;
                protocol_data.signature := signature |} |}) None
        (Data_encoding.merge_objs Operation.shell_header_encoding
          (Data_encoding.obj2
            (Data_encoding.req None None "operations"
              (Pervasives.op_atat
                (let arg := Data_encoding.conv to_list of_list in
                fun eta => arg None eta)
                (Pervasives.op_atat
                  (let arg := Data_encoding.def "inlined.endorsement.contents"
                    in
                  fun eta => arg None None eta)
                  (Data_encoding.union None [ make endorsement_case ]))))
            (Data_encoding.varopt None None "signature" Signature.encoding)))).
  
  Definition seed_nonce_revelation_case : case Kind.seed_nonce_revelation :=
    Case
      {| case.Case.tag := 1; case.Case.name := "seed_nonce_revelation";
        case.Case.encoding :=
          Data_encoding.obj2
            (Data_encoding.req None None "level" Raw_level_repr.encoding)
            (Data_encoding.req None None "nonce" Seed_repr.nonce_encoding);
        case.Case.select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Seed_nonce_revelation _) as op) => Some op
            | _ => None
            end;
        case.Case.proj :=
          fun function_parameter =>
            let
              'Seed_nonce_revelation {|
                contents.Seed_nonce_revelation.level := level;
                  contents.Seed_nonce_revelation.nonce := __nonce_value
                  |} := function_parameter in
            (level, __nonce_value);
        case.Case.inj :=
          fun function_parameter =>
            let '(level, __nonce_value) := function_parameter in
            Seed_nonce_revelation
              {| contents.Seed_nonce_revelation.level := level;
                contents.Seed_nonce_revelation.nonce := __nonce_value |} |}.
  
  Definition double_endorsement_evidence_case
    : case Kind.double_endorsement_evidence :=
    Case
      {| case.Case.tag := 2; case.Case.name := "double_endorsement_evidence";
        case.Case.encoding :=
          Data_encoding.obj2
            (Data_encoding.req None None "op1"
              (Data_encoding.dynamic_size None endorsement_encoding))
            (Data_encoding.req None None "op2"
              (Data_encoding.dynamic_size None endorsement_encoding));
        case.Case.select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Double_endorsement_evidence _) as op) => Some op
            | _ => None
            end;
        case.Case.proj :=
          fun function_parameter =>
            let
              'Double_endorsement_evidence {|
                contents.Double_endorsement_evidence.op1 := op1;
                  contents.Double_endorsement_evidence.op2 := op2
                  |} := function_parameter in
            (op1, op2);
        case.Case.inj :=
          fun function_parameter =>
            let '(op1, op2) := function_parameter in
            Double_endorsement_evidence
              {| contents.Double_endorsement_evidence.op1 := op1;
                contents.Double_endorsement_evidence.op2 := op2 |} |}.
  
  Definition double_baking_evidence_case : case Kind.double_baking_evidence :=
    Case
      {| case.Case.tag := 3; case.Case.name := "double_baking_evidence";
        case.Case.encoding :=
          Data_encoding.obj2
            (Data_encoding.req None None "bh1"
              (Data_encoding.dynamic_size None Block_header_repr.encoding))
            (Data_encoding.req None None "bh2"
              (Data_encoding.dynamic_size None Block_header_repr.encoding));
        case.Case.select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Double_baking_evidence _) as op) => Some op
            | _ => None
            end;
        case.Case.proj :=
          fun function_parameter =>
            let
              'Double_baking_evidence {|
                contents.Double_baking_evidence.bh1 := bh1;
                  contents.Double_baking_evidence.bh2 := bh2
                  |} := function_parameter in
            (bh1, bh2);
        case.Case.inj :=
          fun function_parameter =>
            let '(bh1, bh2) := function_parameter in
            Double_baking_evidence
              {| contents.Double_baking_evidence.bh1 := bh1;
                contents.Double_baking_evidence.bh2 := bh2 |} |}.
  
  Definition activate_account_case : case Kind.activate_account :=
    Case
      {| case.Case.tag := 4; case.Case.name := "activate_account";
        case.Case.encoding :=
          Data_encoding.obj2
            (Data_encoding.req None None "pkh"
              (|Ed25519|).(S.SIGNATURE.Public_key_hash).(S.SPublic_key_hash.encoding))
            (Data_encoding.req None None "secret"
              Blinded_public_key_hash.activation_code_encoding);
        case.Case.select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Activate_account _) as op) => Some op
            | _ => None
            end;
        case.Case.proj :=
          fun function_parameter =>
            let
              'Activate_account {|
                contents.Activate_account.id := id;
                  contents.Activate_account.activation_code := activation_code
                  |} := function_parameter in
            (id, activation_code);
        case.Case.inj :=
          fun function_parameter =>
            let '(id, activation_code) := function_parameter in
            Activate_account
              {| contents.Activate_account.id := id;
                contents.Activate_account.activation_code := activation_code |}
        |}.
  
  Definition proposals_case : case Kind.proposals :=
    Case
      {| case.Case.tag := 5; case.Case.name := "proposals";
        case.Case.encoding :=
          Data_encoding.obj3
            (Data_encoding.req None None "source"
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding))
            (Data_encoding.req None None "period" Voting_period_repr.encoding)
            (Data_encoding.req None None "proposals"
              (Data_encoding.__list_value None
                (|Protocol_hash|).(S.HASH.encoding)));
        case.Case.select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Proposals _) as op) => Some op
            | _ => None
            end;
        case.Case.proj :=
          fun function_parameter =>
            let
              'Proposals {|
                contents.Proposals.source := source;
                  contents.Proposals.period := period;
                  contents.Proposals.proposals := proposals
                  |} := function_parameter in
            (source, period, proposals);
        case.Case.inj :=
          fun function_parameter =>
            let '(source, period, proposals) := function_parameter in
            Proposals
              {| contents.Proposals.source := source;
                contents.Proposals.period := period;
                contents.Proposals.proposals := proposals |} |}.
  
  Definition ballot_case : case Kind.ballot :=
    Case
      {| case.Case.tag := 6; case.Case.name := "ballot";
        case.Case.encoding :=
          Data_encoding.obj4
            (Data_encoding.req None None "source"
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding))
            (Data_encoding.req None None "period" Voting_period_repr.encoding)
            (Data_encoding.req None None "proposal"
              (|Protocol_hash|).(S.HASH.encoding))
            (Data_encoding.req None None "ballot" Vote_repr.ballot_encoding);
        case.Case.select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Ballot _) as op) => Some op
            | _ => None
            end;
        case.Case.proj :=
          fun function_parameter =>
            let
              'Ballot {|
                contents.Ballot.source := source;
                  contents.Ballot.period := period;
                  contents.Ballot.proposal := proposal;
                  contents.Ballot.ballot := ballot
                  |} := function_parameter in
            (source, period, proposal, ballot);
        case.Case.inj :=
          fun function_parameter =>
            let '(source, period, proposal, ballot) := function_parameter in
            Ballot
              {| contents.Ballot.source := source;
                contents.Ballot.period := period;
                contents.Ballot.proposal := proposal;
                contents.Ballot.ballot := ballot |} |}.
  
  Definition manager_encoding
    : Data_encoding.encoding
      ((|Signature.Public_key_hash|).(S.SPublic_key_hash.t) * Tez_repr.t * Z.t *
        Z.t * Z.t) :=
    Data_encoding.obj5
      (Data_encoding.req None None "source"
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding))
      (Data_encoding.req None None "fee" Tez_repr.encoding)
      (Data_encoding.req None None "counter"
        (Data_encoding.check_size 10 Data_encoding.n))
      (Data_encoding.req None None "gas_limit"
        (Data_encoding.check_size 10 Data_encoding.n))
      (Data_encoding.req None None "storage_limit"
        (Data_encoding.check_size 10 Data_encoding.n)).
  
  Definition extract {A : Set} (function_parameter : contents (Kind.manager A))
    : Signature.public_key_hash * Tez_repr.tez * counter * Z.t * Z.t :=
    let
      'Manager_operation {|
        contents.Manager_operation.source := source;
          contents.Manager_operation.fee := fee;
          contents.Manager_operation.counter := counter;
          contents.Manager_operation.operation := _;
          contents.Manager_operation.gas_limit := gas_limit;
          contents.Manager_operation.storage_limit := storage_limit
          |} := function_parameter in
    (source, fee, counter, gas_limit, storage_limit).
  
  Definition rebuild {A : Set}
    (function_parameter :
      Signature.public_key_hash * Tez_repr.tez * counter * Z.t * Z.t)
    : manager_operation A -> contents (Kind.manager A) :=
    let '(source, fee, counter, gas_limit, storage_limit) := function_parameter
      in
    fun operation =>
      Manager_operation
        {| contents.Manager_operation.source := source;
          contents.Manager_operation.fee := fee;
          contents.Manager_operation.counter := counter;
          contents.Manager_operation.operation := operation;
          contents.Manager_operation.gas_limit := gas_limit;
          contents.Manager_operation.storage_limit := storage_limit |}.
  
  Definition make_manager_case {A : Set}
    (tag : Z) (function_parameter : Manager_operations.case A)
    : case (Kind.manager A) :=
    let 'Manager_operations.MCase mcase := function_parameter in
    Case
      {| case.Case.tag := tag;
        case.Case.name := Manager_operations.case.MCase.name mcase;
        case.Case.encoding :=
          Data_encoding.merge_objs manager_encoding
            (Manager_operations.case.MCase.encoding mcase);
        case.Case.select :=
          fun function_parameter =>
            match function_parameter with
            |
              Contents
                (Manager_operation
                  ({| contents.Manager_operation.operation := operation |} as op))
              =>
              match
                (Manager_operations.case.MCase.select mcase) (Manager operation)
                with
              | None => None
              | Some operation =>
                Some
                  (Manager_operation
                    (contents.Manager_operation.with_operation operation op))
              end
            | _ => None
            end;
        case.Case.proj :=
          fun function_parameter =>
            let
              '(Manager_operation {|
                contents.Manager_operation.operation := operation |}) as op :=
              function_parameter in
            ((extract op),
              ((Manager_operations.case.MCase.proj mcase) operation));
        case.Case.inj :=
          fun function_parameter =>
            let '(op, contents) := function_parameter in
            rebuild op ((Manager_operations.case.MCase.inj mcase) contents) |}.
  
  Definition reveal_case : case (Kind.manager Kind.reveal) :=
    make_manager_case 107 Manager_operations.reveal_case.
  
  Definition transaction_case : case (Kind.manager Kind.transaction) :=
    make_manager_case 108 Manager_operations.transaction_case.
  
  Definition origination_case : case (Kind.manager Kind.origination) :=
    make_manager_case 109 Manager_operations.origination_case.
  
  Definition delegation_case : case (Kind.manager Kind.delegation) :=
    make_manager_case 110 Manager_operations.delegation_case.
  
  Definition contents_encoding : Data_encoding.encoding packed_contents :=
    let make {A : Set} (function_parameter : case A)
      : Data_encoding.case packed_contents :=
      let
        'Case {|
          case.Case.tag := tag;
            case.Case.name := name;
            case.Case.encoding := encoding;
            case.Case.select := select;
            case.Case.proj := proj;
            case.Case.inj := inj
            |} := function_parameter in
      __case_value (Data_encoding.Tag tag) name encoding
        (fun o =>
          match select o with
          | None => None
          | Some o => Some (proj o)
          end) (fun x => Contents (inj x)) in
    Pervasives.op_atat
      (let arg := Data_encoding.def "operation.alpha.contents" in
      fun eta => arg None None eta)
      (Data_encoding.union None
        [
          make endorsement_case;
          make seed_nonce_revelation_case;
          make double_endorsement_evidence_case;
          make double_baking_evidence_case;
          make activate_account_case;
          make proposals_case;
          make ballot_case;
          make reveal_case;
          make transaction_case;
          make origination_case;
          make delegation_case
        ]).
  
  Definition contents_list_encoding
    : Data_encoding.encoding packed_contents_list :=
    Data_encoding.conv to_list of_list None
      (Data_encoding.__Variable.__list_value None contents_encoding).
  
  Definition optional_signature_encoding
    : Data_encoding.encoding (option Signature.t) :=
    Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | Some s => s
        | None => Signature.zero
        end)
      (fun s =>
        if Signature.equal s Signature.zero then
          None
        else
          Some s) None Signature.encoding.
  
  Definition protocol_data_encoding
    : Data_encoding.encoding packed_protocol_data :=
    Pervasives.op_atat
      (let arg := Data_encoding.def "operation.alpha.contents_and_signature" in
      fun eta => arg None None eta)
      (Data_encoding.conv
        (fun function_parameter =>
          let
            'Operation_data {|
              protocol_data.contents := contents;
                protocol_data.signature := signature
                |} := function_parameter in
          ((Contents_list contents), signature))
        (fun function_parameter =>
          let '(Contents_list contents, signature) := function_parameter in
          Operation_data
            {| protocol_data.contents := contents;
              protocol_data.signature := signature |}) None
        (Data_encoding.obj2
          (Data_encoding.req None None "contents" contents_list_encoding)
          (Data_encoding.req None None "signature" optional_signature_encoding))).
  
  Definition operation_encoding : Data_encoding.encoding packed_operation :=
    Data_encoding.conv
      (fun function_parameter =>
        let '{|
          packed_operation.shell := shell;
            packed_operation.protocol_data := protocol_data
            |} := function_parameter in
        (shell, protocol_data))
      (fun function_parameter =>
        let '(shell, protocol_data) := function_parameter in
        {| packed_operation.shell := shell;
          packed_operation.protocol_data := protocol_data |}) None
      (Data_encoding.merge_objs Operation.shell_header_encoding
        protocol_data_encoding).
  
  Definition unsigned_operation_encoding
    : Data_encoding.encoding (Operation.shell_header * packed_contents_list) :=
    Pervasives.op_atat
      (let arg := Data_encoding.def "operation.alpha.unsigned_operation" in
      fun eta => arg None None eta)
      (Data_encoding.merge_objs Operation.shell_header_encoding
        (Data_encoding.obj1
          (Data_encoding.req None None "contents" contents_list_encoding))).
  
  Definition internal_operation_encoding
    : Data_encoding.encoding packed_internal_operation :=
    Pervasives.op_atat
      (let arg := Data_encoding.def "operation.alpha.internal_operation" in
      fun eta => arg None None eta)
      (Data_encoding.conv
        (fun function_parameter =>
          let
            'Internal_operation {|
              internal_operation.source := source;
                internal_operation.operation := operation;
                internal_operation.nonce := __nonce_value
                |} := function_parameter in
          ((source, __nonce_value), (Manager operation)))
        (fun function_parameter =>
          let '((source, __nonce_value), Manager operation) :=
            function_parameter in
          Internal_operation
            {| internal_operation.source := source;
              internal_operation.operation := operation;
              internal_operation.nonce := __nonce_value |}) None
        (Data_encoding.merge_objs
          (Data_encoding.obj2
            (Data_encoding.req None None "source" Contract_repr.encoding)
            (Data_encoding.req None None "nonce" Data_encoding.uint16))
          Manager_operations.encoding)).
End Encoding.

Definition encoding : Data_encoding.encoding packed_operation :=
  Encoding.operation_encoding.

Definition contents_encoding : Data_encoding.encoding packed_contents :=
  Encoding.contents_encoding.

Definition contents_list_encoding
  : Data_encoding.encoding packed_contents_list :=
  Encoding.contents_list_encoding.

Definition protocol_data_encoding
  : Data_encoding.encoding packed_protocol_data :=
  Encoding.protocol_data_encoding.

Definition unsigned_operation_encoding
  : Data_encoding.encoding (Operation.shell_header * packed_contents_list) :=
  Encoding.unsigned_operation_encoding.

Definition internal_operation_encoding
  : Data_encoding.encoding packed_internal_operation :=
  Encoding.internal_operation_encoding.

Definition __raw_value {A : Set} (function_parameter : operation A)
  : Operation.t :=
  let '{|
    operation.shell := shell; operation.protocol_data := protocol_data |} :=
    function_parameter in
  let proto :=
    Data_encoding.Binary.to_bytes_exn protocol_data_encoding
      (Operation_data protocol_data) in
  {| Operation.t.shell := shell; Operation.t.proto := proto |}.

Definition acceptable_passes (op : packed_operation) : list Z :=
  let 'Operation_data protocol_data := packed_operation.protocol_data op in
  match protocol_data.contents protocol_data with
  | Single (Endorsement _) => [ 0 ]
  | Single (Proposals _) => [ 1 ]
  | Single (Ballot _) => [ 1 ]
  | Single (Seed_nonce_revelation _) => [ 2 ]
  | Single (Double_endorsement_evidence _) => [ 2 ]
  | Single (Double_baking_evidence _) => [ 2 ]
  | Single (Activate_account _) => [ 2 ]
  | Single (Manager_operation _) => [ 3 ]
  | Cons _ _ => [ 3 ]
  end.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition check_signature_sync {A : Set}
  (key : (|Signature.Public_key|).(S.SPublic_key.t))
  (chain_id : (|Chain_id|).(S.HASH.t)) (function_parameter : operation A)
  : Error_monad.tzresult unit :=
  let '{|
    operation.shell := shell; operation.protocol_data := protocol_data |} :=
    function_parameter in
  let check
    (watermark : Signature.watermark) (contents : packed_contents_list)
    (signature : Signature.t)
    : Pervasives.result unit (list Error_monad.__error) :=
    let unsigned_operation :=
      Data_encoding.Binary.to_bytes_exn unsigned_operation_encoding
        (shell, contents) in
    if Signature.check (Some watermark) key signature unsigned_operation then
      Pervasives.Ok tt
    else
      Error_monad.__error_value extensible_type_value in
  match
    ((protocol_data.contents protocol_data),
      (protocol_data.signature protocol_data)) with
  | (Single _, None) => Error_monad.__error_value extensible_type_value
  | (Cons _ _, None) => Error_monad.__error_value extensible_type_value
  | ((Single (Endorsement _)) as contents, Some signature) =>
    check (Signature.Endorsement chain_id) (Contents_list contents) signature
  | ((Single _) as contents, Some signature) =>
    check Signature.Generic_operation (Contents_list contents) signature
  | ((Cons _ _) as contents, Some signature) =>
    check Signature.Generic_operation (Contents_list contents) signature
  end.

Definition check_signature {A : Set}
  (pk : (|Signature.Public_key|).(S.SPublic_key.t))
  (chain_id : (|Chain_id|).(S.HASH.t)) (op : operation A)
  : Lwt.t (Error_monad.tzresult unit) :=
  Lwt.__return (check_signature_sync pk chain_id op).

Definition hash_raw : Operation.t -> (|Operation_hash|).(S.HASH.t) :=
  Operation.__hash_value.

Definition __hash_value {A : Set} (o : operation A)
  : (|Operation_hash|).(S.HASH.t) :=
  let proto :=
    Data_encoding.Binary.to_bytes_exn protocol_data_encoding
      (Operation_data (operation.protocol_data o)) in
  Operation.__hash_value
    {| raw.shell := operation.shell o; raw.proto := proto |}.

Definition hash_packed (o : packed_operation) : (|Operation_hash|).(S.HASH.t) :=
  let proto :=
    Data_encoding.Binary.to_bytes_exn protocol_data_encoding
      (packed_operation.protocol_data o) in
  Operation.__hash_value
    {| raw.shell := packed_operation.shell o; raw.proto := proto |}.

Reserved Notation "'eq".

Inductive eq_gadt : Set :=
| Eq : eq_gadt

where "'eq" := (fun (_ _ : Set) => eq_gadt).

Definition eq := 'eq.

Definition equal_manager_operation_kind {a b : Set}
  (op1 : manager_operation a) (op2 : manager_operation b) : option (eq a b) :=
  match (op1, op2) with
  | (Reveal _, Reveal _) => Some Eq
  | (Reveal _, _) => None
  | (Transaction _, Transaction _) => Some Eq
  | (Transaction _, _) => None
  | (Origination _, Origination _) => Some Eq
  | (Origination _, _) => None
  | (Delegation _, Delegation _) => Some Eq
  | (Delegation _, _) => None
  end.

Definition equal_contents_kind {a b : Set} (op1 : contents a) (op2 : contents b)
  : option (eq a b) :=
  match (op1, op2) with
  | (Endorsement _, Endorsement _) => Some Eq
  | (Endorsement _, _) => None
  | (Seed_nonce_revelation _, Seed_nonce_revelation _) => Some Eq
  | (Seed_nonce_revelation _, _) => None
  | (Double_endorsement_evidence _, Double_endorsement_evidence _) => Some Eq
  | (Double_endorsement_evidence _, _) => None
  | (Double_baking_evidence _, Double_baking_evidence _) => Some Eq
  | (Double_baking_evidence _, _) => None
  | (Activate_account _, Activate_account _) => Some Eq
  | (Activate_account _, _) => None
  | (Proposals _, Proposals _) => Some Eq
  | (Proposals _, _) => None
  | (Ballot _, Ballot _) => Some Eq
  | (Ballot _, _) => None
  | (Manager_operation op1, Manager_operation op2) =>
    match
      equal_manager_operation_kind (contents.Manager_operation.operation op1)
        (contents.Manager_operation.operation op2) with
    | None => None
    | Some Eq => Some Eq
    end
  | (Manager_operation _, _) => None
  end.

Fixpoint equal_contents_kind_list {a b : Set}
  (op1 : contents_list a) (op2 : contents_list b) {struct op1}
  : option (eq a b) :=
  match (op1, op2) with
  | (Single op1, Single op2) => equal_contents_kind op1 op2
  | (Single _, Cons _ _) => None
  | (Cons _ _, Single _) => None
  | (Cons op1 ops1, Cons op2 ops2) =>
    match equal_contents_kind op1 op2 with
    | None => None
    | Some Eq =>
      match equal_contents_kind_list ops1 ops2 with
      | None => None
      | Some Eq => Some Eq
      end
    end
  end.

Definition equal {a b : Set} (op1 : operation a) (op2 : operation b)
  : option (eq a b) :=
  if
    Pervasives.not
      ((|Operation_hash|).(S.HASH.equal) (__hash_value op1) (__hash_value op2))
    then
    None
  else
    equal_contents_kind_list
      (protocol_data.contents (operation.protocol_data op1))
      (protocol_data.contents (operation.protocol_data op2)).

Operation_repr_mli

  • OCaml size: 269 lines
  • Coq size: 553 lines (+105% compared to OCaml)
operation_repr.mli 2 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Low level Repr. of Operations *)

module Kind : sig
  type seed_nonce_revelation = Seed_nonce_revelation_kind

  type double_endorsement_evidence = Double_endorsement_evidence_kind

  type double_baking_evidence = Double_baking_evidence_kind

  type activate_account = Activate_account_kind

  type endorsement = Endorsement_kind

  type proposals = Proposals_kind

  type ballot = Ballot_kind

  type reveal = Reveal_kind

  type transaction = Transaction_kind

  type origination = Origination_kind

  type delegation = Delegation_kind

  type 'a manager =
    | Reveal_manager_kind : reveal manager
    | Transaction_manager_kind : transaction manager
    | Origination_manager_kind : origination manager
    | Delegation_manager_kind : delegation manager
end

type raw = Operation.t = {shell : Operation.shell_header; proto : MBytes.t}

val raw_encoding : raw Data_encoding.t

type 'kind operation = {
  shell : Operation.shell_header;
  protocol_data : 'kind protocol_data;
}

and 'kind protocol_data = {
  contents : 'kind contents_list;
  signature : Signature.t option;
}

and _ contents_list =
  | Single : 'kind contents -> 'kind contents_list
  | Cons :
      'kind Kind.manager contents * 'rest Kind.manager contents_list
      -> ('kind * 'rest) Kind.manager contents_list

and _ contents =
  | Endorsement : {level : Raw_level_repr.t} -> Kind.endorsement contents
  | Seed_nonce_revelation : {
      level : Raw_level_repr.t;
      nonce : Seed_repr.nonce;
    }
      -> Kind.seed_nonce_revelation contents
  | Double_endorsement_evidence : {
      op1 : Kind.endorsement operation;
      op2 : Kind.endorsement operation;
    }
      -> Kind.double_endorsement_evidence contents
  | Double_baking_evidence : {
      bh1 : Block_header_repr.t;
      bh2 : Block_header_repr.t;
    }
      -> Kind.double_baking_evidence contents
  | Activate_account : {
      id : Ed25519.Public_key_hash.t;
      activation_code : Blinded_public_key_hash.activation_code;
    }
      -> Kind.activate_account contents
  | Proposals : {
      source : Signature.Public_key_hash.t;
      period : Voting_period_repr.t;
      proposals : Protocol_hash.t list;
    }
      -> Kind.proposals contents
  | Ballot : {
      source : Signature.Public_key_hash.t;
      period : Voting_period_repr.t;
      proposal : Protocol_hash.t;
      ballot : Vote_repr.ballot;
    }
      -> Kind.ballot contents
  | Manager_operation : {
      source : Signature.Public_key_hash.t;
      fee : Tez_repr.tez;
      counter : counter;
      operation : 'kind manager_operation;
      gas_limit : Z.t;
      storage_limit : Z.t;
    }
      -> 'kind Kind.manager contents

and _ manager_operation =
  | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation
  | Transaction : {
      amount : Tez_repr.tez;
      parameters : Script_repr.lazy_expr;
      entrypoint : string;
      destination : Contract_repr.contract;
    }
      -> Kind.transaction manager_operation
  | Origination : {
      delegate : Signature.Public_key_hash.t option;
      script : Script_repr.t;
      credit : Tez_repr.tez;
      preorigination : Contract_repr.t option;
    }
      -> Kind.origination manager_operation
  | Delegation :
      Signature.Public_key_hash.t option
      -> Kind.delegation manager_operation

and counter = Z.t

type 'kind internal_operation = {
  source : Contract_repr.contract;
  operation : 'kind manager_operation;
  nonce : int;
}

type packed_manager_operation =
  | Manager : 'kind manager_operation -> packed_manager_operation

type packed_contents = Contents : 'kind contents -> packed_contents

type packed_contents_list =
  | Contents_list : 'kind contents_list -> packed_contents_list

val of_list : packed_contents list -> packed_contents_list

val to_list : packed_contents_list -> packed_contents list

type packed_protocol_data =
  | Operation_data : 'kind protocol_data -> packed_protocol_data

type packed_operation = {
  shell : Operation.shell_header;
  protocol_data : packed_protocol_data;
}

val pack : 'kind operation -> packed_operation

type packed_internal_operation =
  | Internal_operation : 'kind internal_operation -> packed_internal_operation

val manager_kind : 'kind manager_operation -> 'kind Kind.manager

val encoding : packed_operation Data_encoding.t

val contents_encoding : packed_contents Data_encoding.t

val contents_list_encoding : packed_contents_list Data_encoding.t

val protocol_data_encoding : packed_protocol_data Data_encoding.t

val unsigned_operation_encoding :
  (Operation.shell_header * packed_contents_list) Data_encoding.t

val raw : _ operation -> raw

val hash_raw : raw -> Operation_hash.t

val hash : _ operation -> Operation_hash.t

val hash_packed : packed_operation -> Operation_hash.t

val acceptable_passes : packed_operation -> int list

type error += Missing_signature (* `Permanent *)

type error += Invalid_signature (* `Permanent *)

val check_signature :
  Signature.Public_key.t -> Chain_id.t -> _ operation -> unit tzresult Lwt.t

val check_signature_sync :
  Signature.Public_key.t -> Chain_id.t -> _ operation -> unit tzresult

val internal_operation_encoding : packed_internal_operation Data_encoding.t

type ('a, 'b) eq = Eq : ('a, 'a) eq

val equal : 'a operation -> 'b operation -> ('a, 'b) eq option

module Encoding : sig
  type 'b case =
    | Case : {
        tag : int;
        name : string;
        encoding : 'a Data_encoding.t;
        select : packed_contents -> 'b contents option;
        proj : 'b contents -> 'a;
        inj : 'a -> 'b contents;
      }
        -> 'b case

  val endorsement_case : Kind.endorsement case

  val seed_nonce_revelation_case : Kind.seed_nonce_revelation case

  val double_endorsement_evidence_case : Kind.double_endorsement_evidence case

  val double_baking_evidence_case : Kind.double_baking_evidence case

  val activate_account_case : Kind.activate_account case

  val proposals_case : Kind.proposals case

  val ballot_case : Kind.ballot case

  val reveal_case : Kind.reveal Kind.manager case

  val transaction_case : Kind.transaction Kind.manager case

  val origination_case : Kind.origination Kind.manager case

  val delegation_case : Kind.delegation Kind.manager case

  module Manager_operations : sig
    type 'b case =
      | MCase : {
          tag : int;
          name : string;
          encoding : 'a Data_encoding.t;
          select : packed_manager_operation -> 'kind manager_operation option;
          proj : 'kind manager_operation -> 'a;
          inj : 'a -> 'kind manager_operation;
        }
          -> 'kind case

    val reveal_case : Kind.reveal case

    val transaction_case : Kind.transaction case

    val origination_case : Kind.origination case

    val delegation_case : Kind.delegation case
  end
end
Operation_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Blinded_public_key_hash.
Require Tezos.Block_header_repr.
Require Tezos.Contract_repr.
Require Tezos.Raw_level_repr.
Require Tezos.Script_repr.
Require Tezos.Seed_repr.
Require Tezos.Tez_repr.
Require Tezos.Vote_repr.
Require Tezos.Voting_period_repr.

Module Kind.
  Inductive seed_nonce_revelation : Set :=
  | Seed_nonce_revelation_kind : seed_nonce_revelation.
  
  Inductive double_endorsement_evidence : Set :=
  | Double_endorsement_evidence_kind : double_endorsement_evidence.
  
  Inductive double_baking_evidence : Set :=
  | Double_baking_evidence_kind : double_baking_evidence.
  
  Inductive activate_account : Set :=
  | Activate_account_kind : activate_account.
  
  Inductive endorsement : Set :=
  | Endorsement_kind : endorsement.
  
  Inductive proposals : Set :=
  | Proposals_kind : proposals.
  
  Inductive ballot : Set :=
  | Ballot_kind : ballot.
  
  Inductive reveal : Set :=
  | Reveal_kind : reveal.
  
  Inductive transaction : Set :=
  | Transaction_kind : transaction.
  
  Inductive origination : Set :=
  | Origination_kind : origination.
  
  Inductive delegation : Set :=
  | Delegation_kind : delegation.
  
  Reserved Notation "'manager".
  
  Inductive manager_gadt : Set :=
  | Reveal_manager_kind : manager_gadt
  | Transaction_manager_kind : manager_gadt
  | Origination_manager_kind : manager_gadt
  | Delegation_manager_kind : manager_gadt
  
  where "'manager" := (fun (_ : Set) => manager_gadt).
  
  Definition manager := 'manager.
End Kind.

Module raw.
  Record record := Build {
    shell : Operation.shell_header;
    proto : MBytes.t }.
  Definition with_shell shell (r : record) :=
    Build shell r.(proto).
  Definition with_proto proto (r : record) :=
    Build r.(shell) proto.
End raw.
Definition raw := raw.record.

Parameter raw_encoding : Data_encoding.t raw.

Module contents.
  Module Endorsement.
    Record record {level : Set} := {
      level : level }.
    Arguments record : clear implicits.
  End Endorsement.
  Definition Endorsement_skeleton := Endorsement.record.
  
  Module Seed_nonce_revelation.
    Record record {level nonce : Set} := {
      level : level;
      nonce : nonce }.
    Arguments record : clear implicits.
  End Seed_nonce_revelation.
  Definition Seed_nonce_revelation_skeleton := Seed_nonce_revelation.record.
  
  Module Double_endorsement_evidence.
    Record record {op1 op2 : Set} := {
      op1 : op1;
      op2 : op2 }.
    Arguments record : clear implicits.
  End Double_endorsement_evidence.
  Definition Double_endorsement_evidence_skeleton :=
    Double_endorsement_evidence.record.
  
  Module Double_baking_evidence.
    Record record {bh1 bh2 : Set} := {
      bh1 : bh1;
      bh2 : bh2 }.
    Arguments record : clear implicits.
  End Double_baking_evidence.
  Definition Double_baking_evidence_skeleton := Double_baking_evidence.record.
  
  Module Activate_account.
    Record record {id activation_code : Set} := {
      id : id;
      activation_code : activation_code }.
    Arguments record : clear implicits.
  End Activate_account.
  Definition Activate_account_skeleton := Activate_account.record.
  
  Module Proposals.
    Record record {source period proposals : Set} := {
      source : source;
      period : period;
      proposals : proposals }.
    Arguments record : clear implicits.
  End Proposals.
  Definition Proposals_skeleton := Proposals.record.
  
  Module Ballot.
    Record record {source period proposal ballot : Set} := {
      source : source;
      period : period;
      proposal : proposal;
      ballot : ballot }.
    Arguments record : clear implicits.
  End Ballot.
  Definition Ballot_skeleton := Ballot.record.
  
  Module Manager_operation.
    Record record {source fee counter operation gas_limit storage_limit : Set} := {
      source : source;
      fee : fee;
      counter : counter;
      operation : operation;
      gas_limit : gas_limit;
      storage_limit : storage_limit }.
    Arguments record : clear implicits.
  End Manager_operation.
  Definition Manager_operation_skeleton := Manager_operation.record.
End contents.

Module manager_operation.
  Module Transaction.
    Record record {amount parameters entrypoint destination : Set} := {
      amount : amount;
      parameters : parameters;
      entrypoint : entrypoint;
      destination : destination }.
    Arguments record : clear implicits.
  End Transaction.
  Definition Transaction_skeleton := Transaction.record.
  
  Module Origination.
    Record record {delegate script credit preorigination : Set} := {
      delegate : delegate;
      script : script;
      credit : credit;
      preorigination : preorigination }.
    Arguments record : clear implicits.
  End Origination.
  Definition Origination_skeleton := Origination.record.
End manager_operation.

Module protocol_data.
  Record record {contents signature : Set} := Build {
    contents : contents;
    signature : signature }.
  Arguments record : clear implicits.
  Definition with_contents {t_contents t_signature} contents
    (r : record t_contents t_signature) :=
    Build t_contents t_signature contents r.(signature).
  Definition with_signature {t_contents t_signature} signature
    (r : record t_contents t_signature) :=
    Build t_contents t_signature r.(contents) signature.
End protocol_data.
Definition protocol_data_skeleton := protocol_data.record.

Module operation.
  Record record {shell protocol_data : Set} := Build {
    shell : shell;
    protocol_data : protocol_data }.
  Arguments record : clear implicits.
  Definition with_shell {t_shell t_protocol_data} shell
    (r : record t_shell t_protocol_data) :=
    Build t_shell t_protocol_data shell r.(protocol_data).
  Definition with_protocol_data {t_shell t_protocol_data} protocol_data
    (r : record t_shell t_protocol_data) :=
    Build t_shell t_protocol_data r.(shell) protocol_data.
End operation.
Definition operation_skeleton := operation.record.

Reserved Notation "'contents.Endorsement".
Reserved Notation "'contents.Seed_nonce_revelation".
Reserved Notation "'contents.Double_endorsement_evidence".
Reserved Notation "'contents.Double_baking_evidence".
Reserved Notation "'contents.Activate_account".
Reserved Notation "'contents.Proposals".
Reserved Notation "'contents.Ballot".
Reserved Notation "'contents.Manager_operation".
Reserved Notation "'manager_operation.Transaction".
Reserved Notation "'manager_operation.Origination".
Reserved Notation "'operation".
Reserved Notation "'protocol_data".
Reserved Notation "'contents_list".
Reserved Notation "'contents".
Reserved Notation "'manager_operation".
Reserved Notation "'counter".

Inductive contents_list_gadt : Set :=
| Single : forall {kind : Set}, 'contents kind -> contents_list_gadt
| Cons : forall {kind : Set},
  'contents (Kind.manager kind) -> contents_list_gadt -> contents_list_gadt

with contents_gadt : Set :=
| Endorsement : 'contents.Endorsement -> contents_gadt
| Seed_nonce_revelation : 'contents.Seed_nonce_revelation -> contents_gadt
| Double_endorsement_evidence :
  'contents.Double_endorsement_evidence -> contents_gadt
| Double_baking_evidence : 'contents.Double_baking_evidence -> contents_gadt
| Activate_account : 'contents.Activate_account -> contents_gadt
| Proposals : 'contents.Proposals -> contents_gadt
| Ballot : 'contents.Ballot -> contents_gadt
| Manager_operation : forall {kind : Set},
  'contents.Manager_operation kind -> contents_gadt

with manager_operation_gadt : Set :=
| Reveal : (|Signature.Public_key|).(S.SPublic_key.t) -> manager_operation_gadt
| Transaction : 'manager_operation.Transaction -> manager_operation_gadt
| Origination : 'manager_operation.Origination -> manager_operation_gadt
| Delegation :
  option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  manager_operation_gadt

where "'operation" := (fun (t_kind : Set) =>
  operation_skeleton Operation.shell_header ('protocol_data t_kind))
and "'protocol_data" := (fun (t_kind : Set) =>
  protocol_data_skeleton ('contents_list t_kind) (option Signature.t))
and "'contents_list" := (fun (_ : Set) => contents_list_gadt)
and "'contents" := (fun (_ : Set) => contents_gadt)
and "'manager_operation" := (fun (_ : Set) => manager_operation_gadt)
and "'counter" := (Z.t)
and "'contents.Endorsement" := (contents.Endorsement_skeleton Raw_level_repr.t)
and "'contents.Seed_nonce_revelation" :=
  (contents.Seed_nonce_revelation_skeleton Raw_level_repr.t Seed_repr.nonce)
and "'contents.Double_endorsement_evidence" :=
  (contents.Double_endorsement_evidence_skeleton ('operation Kind.endorsement)
    ('operation Kind.endorsement))
and "'contents.Double_baking_evidence" :=
  (contents.Double_baking_evidence_skeleton Block_header_repr.t
    Block_header_repr.t)
and "'contents.Activate_account" :=
  (contents.Activate_account_skeleton
    (|Ed25519|).(S.SIGNATURE.Public_key_hash).(S.SPublic_key_hash.t)
    Blinded_public_key_hash.activation_code)
and "'contents.Proposals" :=
  (contents.Proposals_skeleton
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) Voting_period_repr.t
    (list (|Protocol_hash|).(S.HASH.t)))
and "'contents.Ballot" :=
  (contents.Ballot_skeleton (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)
    Voting_period_repr.t (|Protocol_hash|).(S.HASH.t) Vote_repr.ballot)
and "'contents.Manager_operation" := (fun (t_kind : Set) =>
  contents.Manager_operation_skeleton
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) Tez_repr.tez 'counter
    ('manager_operation t_kind) Z.t Z.t)
and "'manager_operation.Transaction" :=
  (manager_operation.Transaction_skeleton Tez_repr.tez Script_repr.lazy_expr
    string Contract_repr.contract)
and "'manager_operation.Origination" :=
  (manager_operation.Origination_skeleton
    (option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)) Script_repr.t
    Tez_repr.tez (option Contract_repr.t)).

Module
  ConstructorRecordNotations_contents_list_gadt_contents_gadt_manager_operation_gadt.
  Module contents.
    Definition Endorsement := 'contents.Endorsement.
    Definition Seed_nonce_revelation := 'contents.Seed_nonce_revelation.
    Definition Double_endorsement_evidence :=
      'contents.Double_endorsement_evidence.
    Definition Double_baking_evidence := 'contents.Double_baking_evidence.
    Definition Activate_account := 'contents.Activate_account.
    Definition Proposals := 'contents.Proposals.
    Definition Ballot := 'contents.Ballot.
    Definition Manager_operation := 'contents.Manager_operation.
  End contents.
  Module manager_operation.
    Definition Transaction := 'manager_operation.Transaction.
    Definition Origination := 'manager_operation.Origination.
  End manager_operation.
End
  ConstructorRecordNotations_contents_list_gadt_contents_gadt_manager_operation_gadt.
Import
  ConstructorRecordNotations_contents_list_gadt_contents_gadt_manager_operation_gadt.

Definition operation := 'operation.
Definition protocol_data := 'protocol_data.
Definition contents_list := 'contents_list.
Definition contents := 'contents.
Definition manager_operation := 'manager_operation.
Definition counter := 'counter.

Module internal_operation.
  Record record {kind : Set} := Build {
    source : Contract_repr.contract;
    operation : manager_operation kind;
    nonce : Z }.
  Arguments record : clear implicits.
  Definition with_source {t_kind} source (r : record t_kind) :=
    Build t_kind source r.(operation) r.(nonce).
  Definition with_operation {t_kind} operation (r : record t_kind) :=
    Build t_kind r.(source) operation r.(nonce).
  Definition with_nonce {t_kind} nonce (r : record t_kind) :=
    Build t_kind r.(source) r.(operation) nonce.
End internal_operation.
Definition internal_operation := internal_operation.record.

Reserved Notation "'packed_manager_operation".

Inductive packed_manager_operation_gadt : Set :=
| Manager : forall {kind : Set},
  manager_operation kind -> packed_manager_operation_gadt

where "'packed_manager_operation" := (packed_manager_operation_gadt).

Definition packed_manager_operation := 'packed_manager_operation.

Reserved Notation "'packed_contents".

Inductive packed_contents_gadt : Set :=
| Contents : forall {kind : Set}, contents kind -> packed_contents_gadt

where "'packed_contents" := (packed_contents_gadt).

Definition packed_contents := 'packed_contents.

Reserved Notation "'packed_contents_list".

Inductive packed_contents_list_gadt : Set :=
| Contents_list : forall {kind : Set},
  contents_list kind -> packed_contents_list_gadt

where "'packed_contents_list" := (packed_contents_list_gadt).

Definition packed_contents_list := 'packed_contents_list.

Parameter of_list : list packed_contents -> packed_contents_list.

Parameter to_list : packed_contents_list -> list packed_contents.

Reserved Notation "'packed_protocol_data".

Inductive packed_protocol_data_gadt : Set :=
| Operation_data : forall {kind : Set},
  protocol_data kind -> packed_protocol_data_gadt

where "'packed_protocol_data" := (packed_protocol_data_gadt).

Definition packed_protocol_data := 'packed_protocol_data.

Module packed_operation.
  Record record := Build {
    shell : Operation.shell_header;
    protocol_data : packed_protocol_data }.
  Definition with_shell shell (r : record) :=
    Build shell r.(protocol_data).
  Definition with_protocol_data protocol_data (r : record) :=
    Build r.(shell) protocol_data.
End packed_operation.
Definition packed_operation := packed_operation.record.

Parameter pack : forall {kind : Set}, operation kind -> packed_operation.

Reserved Notation "'packed_internal_operation".

Inductive packed_internal_operation_gadt : Set :=
| Internal_operation : forall {kind : Set},
  internal_operation kind -> packed_internal_operation_gadt

where "'packed_internal_operation" := (packed_internal_operation_gadt).

Definition packed_internal_operation := 'packed_internal_operation.

Parameter manager_kind : forall {kind : Set},
  manager_operation kind -> Kind.manager kind.

Parameter encoding : Data_encoding.t packed_operation.

Parameter contents_encoding : Data_encoding.t packed_contents.

Parameter contents_list_encoding : Data_encoding.t packed_contents_list.

Parameter protocol_data_encoding : Data_encoding.t packed_protocol_data.

Parameter unsigned_operation_encoding :
  Data_encoding.t (Operation.shell_header * packed_contents_list).

Parameter __raw_value : forall {A : Set}, operation A -> raw.

Parameter hash_raw : raw -> (|Operation_hash|).(S.HASH.t).

Parameter __hash_value : forall {A : Set},
  operation A -> (|Operation_hash|).(S.HASH.t).

Parameter hash_packed : packed_operation -> (|Operation_hash|).(S.HASH.t).

Parameter acceptable_passes : packed_operation -> list Z.

(* extensible_type error *)

(* extensible_type error *)

Parameter check_signature : forall {A : Set},
  (|Signature.Public_key|).(S.SPublic_key.t) -> (|Chain_id|).(S.HASH.t) ->
  operation A -> Lwt.t (Error_monad.tzresult unit).

Parameter check_signature_sync : forall {A : Set},
  (|Signature.Public_key|).(S.SPublic_key.t) -> (|Chain_id|).(S.HASH.t) ->
  operation A -> Error_monad.tzresult unit.

Parameter internal_operation_encoding :
  Data_encoding.t packed_internal_operation.

Reserved Notation "'eq".

Inductive eq_gadt : Set :=
| Eq : eq_gadt

where "'eq" := (fun (_ _ : Set) => eq_gadt).

Definition eq := 'eq.

Parameter equal : forall {a b : Set},
  operation a -> operation b -> option (eq a b).

Module Encoding.
  Module case.
    Module Case.
      Record record {tag name encoding select proj inj : Set} := {
        tag : tag;
        name : name;
        encoding : encoding;
        select : select;
        proj : proj;
        inj : inj }.
      Arguments record : clear implicits.
    End Case.
    Definition Case_skeleton := Case.record.
  End case.
  
  Reserved Notation "'case.Case".
  Reserved Notation "'case".
  
  Inductive case_gadt : Set :=
  | Case : forall {a b : Set}, 'case.Case a b -> case_gadt
  
  where "'case" := (fun (_ : Set) => case_gadt)
  and "'case.Case" := (fun (t_a t_b : Set) =>
    case.Case_skeleton Z string (Data_encoding.t t_a)
      (packed_contents -> option (contents t_b)) (contents t_b -> t_a)
      (t_a -> contents t_b)).
  
  Module ConstructorRecordNotations_case_gadt.
    Module case.
      Definition Case := 'case.Case.
    End case.
  End ConstructorRecordNotations_case_gadt.
  Import ConstructorRecordNotations_case_gadt.
  
  Definition case := 'case.
  
  Parameter endorsement_case : case Kind.endorsement.
  
  Parameter seed_nonce_revelation_case : case Kind.seed_nonce_revelation.
  
  Parameter double_endorsement_evidence_case :
    case Kind.double_endorsement_evidence.
  
  Parameter double_baking_evidence_case : case Kind.double_baking_evidence.
  
  Parameter activate_account_case : case Kind.activate_account.
  
  Parameter proposals_case : case Kind.proposals.
  
  Parameter ballot_case : case Kind.ballot.
  
  Parameter reveal_case : case (Kind.manager Kind.reveal).
  
  Parameter transaction_case : case (Kind.manager Kind.transaction).
  
  Parameter origination_case : case (Kind.manager Kind.origination).
  
  Parameter delegation_case : case (Kind.manager Kind.delegation).
  
  Module Manager_operations.
    Module case.
      Module MCase.
        Record record {tag name encoding select proj inj : Set} := {
          tag : tag;
          name : name;
          encoding : encoding;
          select : select;
          proj : proj;
          inj : inj }.
        Arguments record : clear implicits.
      End MCase.
      Definition MCase_skeleton := MCase.record.
    End case.
    
    Reserved Notation "'case.MCase".
    Reserved Notation "'case".
    
    Inductive case_gadt : Set :=
    | MCase : forall {a kind : Set}, 'case.MCase a kind -> case_gadt
    
    where "'case" := (fun (_ : Set) => case_gadt)
    and "'case.MCase" := (fun (t_a t_kind : Set) =>
      case.MCase_skeleton Z string (Data_encoding.t t_a)
        (packed_manager_operation -> option (manager_operation t_kind))
        (manager_operation t_kind -> t_a) (t_a -> manager_operation t_kind)).
    
    Module ConstructorRecordNotations_case_gadt.
      Module case.
        Definition MCase := 'case.MCase.
      End case.
    End ConstructorRecordNotations_case_gadt.
    Import ConstructorRecordNotations_case_gadt.
    
    Definition case := 'case.
    
    Parameter reveal_case : case Kind.reveal.
    
    Parameter transaction_case : case Kind.transaction.
    
    Parameter origination_case : case Kind.origination.
    
    Parameter delegation_case : case Kind.delegation.
  End Manager_operations.
End Encoding.

Parameters_repr

  • OCaml size: 127 lines
  • Coq size: 178 lines (+40% compared to OCaml)
parameters_repr.ml 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type bootstrap_account = {
  public_key_hash : Signature.Public_key_hash.t;
  public_key : Signature.Public_key.t option;
  amount : Tez_repr.t;
}

type bootstrap_contract = {
  delegate : Signature.Public_key_hash.t;
  amount : Tez_repr.t;
  script : Script_repr.t;
}

type t = {
  bootstrap_accounts : bootstrap_account list;
  bootstrap_contracts : bootstrap_contract list;
  commitments : Commitment_repr.t list;
  constants : Constants_repr.parametric;
  security_deposit_ramp_up_cycles : int option;
  no_reward_cycles : int option;
}

let bootstrap_account_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Public_key_known"
        (tup2 Signature.Public_key.encoding Tez_repr.encoding)
        (function
          | {public_key_hash; public_key = Some public_key; amount} ->
              assert (
                Signature.Public_key_hash.equal
                  (Signature.Public_key.hash public_key)
                  public_key_hash ) ;
              Some (public_key, amount)
          | {public_key = None} ->
              None)
        (fun (public_key, amount) ->
          {
            public_key = Some public_key;
            public_key_hash = Signature.Public_key.hash public_key;
            amount;
          });
      case
        (Tag 1)
        ~title:"Public_key_unknown"
        (tup2 Signature.Public_key_hash.encoding Tez_repr.encoding)
        (function
          | {public_key_hash; public_key = None; amount} ->
              Some (public_key_hash, amount)
          | {public_key = Some _} ->
              None)
        (fun (public_key_hash, amount) ->
          {public_key = None; public_key_hash; amount}) ]

let bootstrap_contract_encoding =
  let open Data_encoding in
  conv
    (fun {delegate; amount; script} -> (delegate, amount, script))
    (fun (delegate, amount, script) -> {delegate; amount; script})
    (obj3
       (req "delegate" Signature.Public_key_hash.encoding)
       (req "amount" Tez_repr.encoding)
       (req "script" Script_repr.encoding))

let encoding =
  let open Data_encoding in
  conv
    (fun { bootstrap_accounts;
           bootstrap_contracts;
           commitments;
           constants;
           security_deposit_ramp_up_cycles;
           no_reward_cycles } ->
      ( ( bootstrap_accounts,
          bootstrap_contracts,
          commitments,
          security_deposit_ramp_up_cycles,
          no_reward_cycles ),
        constants ))
    (fun ( ( bootstrap_accounts,
             bootstrap_contracts,
             commitments,
             security_deposit_ramp_up_cycles,
             no_reward_cycles ),
           constants ) ->
      {
        bootstrap_accounts;
        bootstrap_contracts;
        commitments;
        constants;
        security_deposit_ramp_up_cycles;
        no_reward_cycles;
      })
    (merge_objs
       (obj5
          (req "bootstrap_accounts" (list bootstrap_account_encoding))
          (dft "bootstrap_contracts" (list bootstrap_contract_encoding) [])
          (dft "commitments" (list Commitment_repr.encoding) [])
          (opt "security_deposit_ramp_up_cycles" int31)
          (opt "no_reward_cycles" int31))
       Constants_repr.parametric_encoding)
Parameters_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Commitment_repr.
Require Tezos.Constants_repr.
Require Tezos.Script_repr.
Require Tezos.Tez_repr.

Module bootstrap_account.
  Record record := Build {
    public_key_hash : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
    public_key : option (|Signature.Public_key|).(S.SPublic_key.t);
    amount : Tez_repr.t }.
  Definition with_public_key_hash public_key_hash (r : record) :=
    Build public_key_hash r.(public_key) r.(amount).
  Definition with_public_key public_key (r : record) :=
    Build r.(public_key_hash) public_key r.(amount).
  Definition with_amount amount (r : record) :=
    Build r.(public_key_hash) r.(public_key) amount.
End bootstrap_account.
Definition bootstrap_account := bootstrap_account.record.

Module bootstrap_contract.
  Record record := Build {
    delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
    amount : Tez_repr.t;
    script : Script_repr.t }.
  Definition with_delegate delegate (r : record) :=
    Build delegate r.(amount) r.(script).
  Definition with_amount amount (r : record) :=
    Build r.(delegate) amount r.(script).
  Definition with_script script (r : record) :=
    Build r.(delegate) r.(amount) script.
End bootstrap_contract.
Definition bootstrap_contract := bootstrap_contract.record.

Module t.
  Record record := Build {
    bootstrap_accounts : list bootstrap_account;
    bootstrap_contracts : list bootstrap_contract;
    commitments : list Commitment_repr.t;
    constants : Constants_repr.parametric;
    security_deposit_ramp_up_cycles : option Z;
    no_reward_cycles : option Z }.
  Definition with_bootstrap_accounts bootstrap_accounts (r : record) :=
    Build bootstrap_accounts r.(bootstrap_contracts) r.(commitments)
      r.(constants) r.(security_deposit_ramp_up_cycles) r.(no_reward_cycles).
  Definition with_bootstrap_contracts bootstrap_contracts (r : record) :=
    Build r.(bootstrap_accounts) bootstrap_contracts r.(commitments)
      r.(constants) r.(security_deposit_ramp_up_cycles) r.(no_reward_cycles).
  Definition with_commitments commitments (r : record) :=
    Build r.(bootstrap_accounts) r.(bootstrap_contracts) commitments
      r.(constants) r.(security_deposit_ramp_up_cycles) r.(no_reward_cycles).
  Definition with_constants constants (r : record) :=
    Build r.(bootstrap_accounts) r.(bootstrap_contracts) r.(commitments)
      constants r.(security_deposit_ramp_up_cycles) r.(no_reward_cycles).
  Definition with_security_deposit_ramp_up_cycles
    security_deposit_ramp_up_cycles (r : record) :=
    Build r.(bootstrap_accounts) r.(bootstrap_contracts) r.(commitments)
      r.(constants) security_deposit_ramp_up_cycles r.(no_reward_cycles).
  Definition with_no_reward_cycles no_reward_cycles (r : record) :=
    Build r.(bootstrap_accounts) r.(bootstrap_contracts) r.(commitments)
      r.(constants) r.(security_deposit_ramp_up_cycles) no_reward_cycles.
End t.
Definition t := t.record.

Definition bootstrap_account_encoding
  : Data_encoding.encoding bootstrap_account :=
  Data_encoding.union None
    [
      Data_encoding.__case_value "Public_key_known" None (Data_encoding.Tag 0)
        (Data_encoding.tup2 (|Signature.Public_key|).(S.SPublic_key.encoding)
          Tez_repr.encoding)
        (fun function_parameter =>
          match function_parameter with
          | {|
            bootstrap_account.public_key_hash := public_key_hash;
              bootstrap_account.public_key := Some public_key;
              bootstrap_account.amount := amount
              |} =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            (* ❌ instruction_sequence ";" *)
            Some (public_key, amount)
          | {| bootstrap_account.public_key := None |} => None
          end)
        (fun function_parameter =>
          let '(public_key, amount) := function_parameter in
          {|
            bootstrap_account.public_key_hash :=
              (|Signature.Public_key|).(S.SPublic_key.__hash_value)
                public_key;
            bootstrap_account.public_key := Some public_key;
            bootstrap_account.amount := amount |});
      Data_encoding.__case_value "Public_key_unknown" None (Data_encoding.Tag 1)
        (Data_encoding.tup2
          (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding)
          Tez_repr.encoding)
        (fun function_parameter =>
          match function_parameter with
          | {|
            bootstrap_account.public_key_hash := public_key_hash;
              bootstrap_account.public_key := None;
              bootstrap_account.amount := amount
              |} => Some (public_key_hash, amount)
          | {| bootstrap_account.public_key := Some _ |} => None
          end)
        (fun function_parameter =>
          let '(public_key_hash, amount) := function_parameter in
          {| bootstrap_account.public_key_hash := public_key_hash;
            bootstrap_account.public_key := None;
            bootstrap_account.amount := amount |})
    ].

Definition bootstrap_contract_encoding
  : Data_encoding.encoding bootstrap_contract :=
  Data_encoding.conv
    (fun function_parameter =>
      let '{|
        bootstrap_contract.delegate := delegate;
          bootstrap_contract.amount := amount;
          bootstrap_contract.script := script
          |} := function_parameter in
      (delegate, amount, script))
    (fun function_parameter =>
      let '(delegate, amount, script) := function_parameter in
      {| bootstrap_contract.delegate := delegate;
        bootstrap_contract.amount := amount; bootstrap_contract.script := script
        |}) None
    (Data_encoding.obj3
      (Data_encoding.req None None "delegate"
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding))
      (Data_encoding.req None None "amount" Tez_repr.encoding)
      (Data_encoding.req None None "script" Script_repr.encoding)).

Definition encoding : Data_encoding.encoding t :=
  Data_encoding.conv
    (fun function_parameter =>
      let '{|
        t.bootstrap_accounts := bootstrap_accounts;
          t.bootstrap_contracts := bootstrap_contracts;
          t.commitments := commitments;
          t.constants := constants;
          t.security_deposit_ramp_up_cycles := security_deposit_ramp_up_cycles;
          t.no_reward_cycles := no_reward_cycles
          |} := function_parameter in
      ((bootstrap_accounts, bootstrap_contracts, commitments,
        security_deposit_ramp_up_cycles, no_reward_cycles), constants))
    (fun function_parameter =>
      let
        '((bootstrap_accounts, bootstrap_contracts, commitments,
          security_deposit_ramp_up_cycles, no_reward_cycles), constants) :=
        function_parameter in
      {| t.bootstrap_accounts := bootstrap_accounts;
        t.bootstrap_contracts := bootstrap_contracts;
        t.commitments := commitments; t.constants := constants;
        t.security_deposit_ramp_up_cycles := security_deposit_ramp_up_cycles;
        t.no_reward_cycles := no_reward_cycles |}) None
    (Data_encoding.merge_objs
      (Data_encoding.obj5
        (Data_encoding.req None None "bootstrap_accounts"
          (Data_encoding.__list_value None bootstrap_account_encoding))
        (Data_encoding.dft None None "bootstrap_contracts"
          (Data_encoding.__list_value None bootstrap_contract_encoding) [])
        (Data_encoding.dft None None "commitments"
          (Data_encoding.__list_value None Commitment_repr.encoding) [])
        (Data_encoding.opt None None "security_deposit_ramp_up_cycles"
          Data_encoding.int31)
        (Data_encoding.opt None None "no_reward_cycles" Data_encoding.int31))
      Constants_repr.parametric_encoding).

Parameters_repr_mli

  • OCaml size: 47 lines
  • Coq size: 76 lines (+61% compared to OCaml)
parameters_repr.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type bootstrap_account = {
  public_key_hash : Signature.Public_key_hash.t;
  public_key : Signature.Public_key.t option;
  amount : Tez_repr.t;
}

type bootstrap_contract = {
  delegate : Signature.Public_key_hash.t;
  amount : Tez_repr.t;
  script : Script_repr.t;
}

type t = {
  bootstrap_accounts : bootstrap_account list;
  bootstrap_contracts : bootstrap_contract list;
  commitments : Commitment_repr.t list;
  constants : Constants_repr.parametric;
  security_deposit_ramp_up_cycles : int option;
  no_reward_cycles : int option;
}

val encoding : t Data_encoding.t
Parameters_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Commitment_repr.
Require Tezos.Constants_repr.
Require Tezos.Script_repr.
Require Tezos.Tez_repr.

Module bootstrap_account.
  Record record := Build {
    public_key_hash : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
    public_key : option (|Signature.Public_key|).(S.SPublic_key.t);
    amount : Tez_repr.t }.
  Definition with_public_key_hash public_key_hash (r : record) :=
    Build public_key_hash r.(public_key) r.(amount).
  Definition with_public_key public_key (r : record) :=
    Build r.(public_key_hash) public_key r.(amount).
  Definition with_amount amount (r : record) :=
    Build r.(public_key_hash) r.(public_key) amount.
End bootstrap_account.
Definition bootstrap_account := bootstrap_account.record.

Module bootstrap_contract.
  Record record := Build {
    delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
    amount : Tez_repr.t;
    script : Script_repr.t }.
  Definition with_delegate delegate (r : record) :=
    Build delegate r.(amount) r.(script).
  Definition with_amount amount (r : record) :=
    Build r.(delegate) amount r.(script).
  Definition with_script script (r : record) :=
    Build r.(delegate) r.(amount) script.
End bootstrap_contract.
Definition bootstrap_contract := bootstrap_contract.record.

Module t.
  Record record := Build {
    bootstrap_accounts : list bootstrap_account;
    bootstrap_contracts : list bootstrap_contract;
    commitments : list Commitment_repr.t;
    constants : Constants_repr.parametric;
    security_deposit_ramp_up_cycles : option Z;
    no_reward_cycles : option Z }.
  Definition with_bootstrap_accounts bootstrap_accounts (r : record) :=
    Build bootstrap_accounts r.(bootstrap_contracts) r.(commitments)
      r.(constants) r.(security_deposit_ramp_up_cycles) r.(no_reward_cycles).
  Definition with_bootstrap_contracts bootstrap_contracts (r : record) :=
    Build r.(bootstrap_accounts) bootstrap_contracts r.(commitments)
      r.(constants) r.(security_deposit_ramp_up_cycles) r.(no_reward_cycles).
  Definition with_commitments commitments (r : record) :=
    Build r.(bootstrap_accounts) r.(bootstrap_contracts) commitments
      r.(constants) r.(security_deposit_ramp_up_cycles) r.(no_reward_cycles).
  Definition with_constants constants (r : record) :=
    Build r.(bootstrap_accounts) r.(bootstrap_contracts) r.(commitments)
      constants r.(security_deposit_ramp_up_cycles) r.(no_reward_cycles).
  Definition with_security_deposit_ramp_up_cycles
    security_deposit_ramp_up_cycles (r : record) :=
    Build r.(bootstrap_accounts) r.(bootstrap_contracts) r.(commitments)
      r.(constants) security_deposit_ramp_up_cycles r.(no_reward_cycles).
  Definition with_no_reward_cycles no_reward_cycles (r : record) :=
    Build r.(bootstrap_accounts) r.(bootstrap_contracts) r.(commitments)
      r.(constants) r.(security_deposit_ramp_up_cycles) no_reward_cycles.
End t.
Definition t := t.record.

Parameter encoding : Data_encoding.t t.

Period_repr

  • OCaml size: 87 lines
  • Coq size: 104 lines (+19% compared to OCaml)
period_repr.ml 4 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Int64.t

type period = t

include (Compare.Int64 : Compare.S with type t := t)

let encoding = Data_encoding.int64

let rpc_arg = RPC_arg.int64

let pp ppf v = Format.fprintf ppf "%Ld" v

type error += (* `Permanent *)
                Malformed_period | Invalid_arg

let () =
  let open Data_encoding in
  (* Malformed period *)
  register_error_kind
    `Permanent
    ~id:"malformed_period"
    ~title:"Malformed period"
    ~description:"Period is negative."
    ~pp:(fun ppf () -> Format.fprintf ppf "Malformed period")
    empty
    (function Malformed_period -> Some () | _ -> None)
    (fun () -> Malformed_period) ;
  (* Invalid arg *)
  register_error_kind
    `Permanent
    ~id:"invalid_arg"
    ~title:"Invalid arg"
    ~description:"Negative multiple of periods are not allowed."
    ~pp:(fun ppf () -> Format.fprintf ppf "Invalid arg")
    empty
    (function Invalid_arg -> Some () | _ -> None)
    (fun () -> Invalid_arg)

let of_seconds t =
  if Compare.Int64.(t >= 0L) then ok t else error Malformed_period

let to_seconds t = t

let of_seconds_exn t =
  match of_seconds t with
  | Ok t ->
      t
  | _ ->
      invalid_arg "Period.of_seconds_exn"

let mult i p =
  (* TODO check overflow *)
  if Compare.Int32.(i < 0l) then error Invalid_arg
  else ok (Int64.mul (Int64.of_int32 i) p)

let zero = of_seconds_exn 0L

let one_second = of_seconds_exn 1L

let one_minute = of_seconds_exn 60L

let one_hour = of_seconds_exn 3600L
Period_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Definition t := Int64.t.

Definition period := t.

Definition op_eq := (|Compare.Int64|).(Compare.S.op_eq).

Definition op_ltgt := (|Compare.Int64|).(Compare.S.op_ltgt).

Definition op_lt := (|Compare.Int64|).(Compare.S.op_lt).

Definition op_lteq := (|Compare.Int64|).(Compare.S.op_lteq).

Definition op_gteq := (|Compare.Int64|).(Compare.S.op_gteq).

Definition op_gt := (|Compare.Int64|).(Compare.S.op_gt).

Definition compare := (|Compare.Int64|).(Compare.S.compare).

Definition equal := (|Compare.Int64|).(Compare.S.equal).

Definition max := (|Compare.Int64|).(Compare.S.max).

Definition min := (|Compare.Int64|).(Compare.S.min).

Definition encoding : Data_encoding.encoding int64 :=
  Data_encoding.__int64_value.

Definition rpc_arg : RPC_arg.arg int64 := RPC_arg.__int64_value.

Definition pp (ppf : Format.formatter) (v : int64) : unit :=
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Int64 CamlinternalFormatBasics.Int_d
        CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.No_precision
        CamlinternalFormatBasics.End_of_format) "%Ld") v.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition of_seconds (__t_value : (|Compare.Int64|).(Compare.S.t))
  : Error_monad.tzresult (|Compare.Int64|).(Compare.S.t) :=
  if
    (|Compare.Int64|).(Compare.S.op_gteq) __t_value
      (* ❌ Constant of type int64 is converted to int *)
      0 then
    Error_monad.ok __t_value
  else
    Error_monad.__error_value extensible_type_value.

Definition to_seconds {A : Set} (__t_value : A) : A := __t_value.

Definition of_seconds_exn (__t_value : (|Compare.Int64|).(Compare.S.t))
  : (|Compare.Int64|).(Compare.S.t) :=
  match of_seconds __t_value with
  | Pervasives.Ok __t_value => __t_value
  | _ => Pervasives.invalid_arg "Period.of_seconds_exn"
  end.

Definition mult (i : (|Compare.Int32|).(Compare.S.t)) (p : int64)
  : Error_monad.tzresult int64 :=
  if
    (|Compare.Int32|).(Compare.S.op_lt) i
      (* ❌ Constant of type int32 is converted to int *)
      0 then
    Error_monad.__error_value extensible_type_value
  else
    Error_monad.ok (Int64.mul (Int64.of_int32 i) p).

Definition zero : (|Compare.Int64|).(Compare.S.t) :=
  of_seconds_exn
    (* ❌ Constant of type int64 is converted to int *)
    0.

Definition one_second : (|Compare.Int64|).(Compare.S.t) :=
  of_seconds_exn
    (* ❌ Constant of type int64 is converted to int *)
    1.

Definition one_minute : (|Compare.Int64|).(Compare.S.t) :=
  of_seconds_exn
    (* ❌ Constant of type int64 is converted to int *)
    60.

Definition one_hour : (|Compare.Int64|).(Compare.S.t) :=
  of_seconds_exn
    (* ❌ Constant of type int64 is converted to int *)
    3600.

Period_repr_mli

  • OCaml size: 55 lines
  • Coq size: 60 lines (+9% compared to OCaml)
period_repr.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t

type period = t

include Compare.S with type t := t

val encoding : period Data_encoding.t

val rpc_arg : period RPC_arg.t

val pp : Format.formatter -> period -> unit

val to_seconds : period -> int64

(** [of_second period] fails if period is not positive *)
val of_seconds : int64 -> period tzresult

(** [of_second period] fails if period is not positive.
    It should only be used at toplevel for constants. *)
val of_seconds_exn : int64 -> period

val mult : int32 -> period -> period tzresult

val zero : period

val one_second : period

val one_minute : period

val one_hour : period
Period_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Parameter t : Set.

Definition period := t.

Parameter Included_S : {_ : unit & Compare.S.signature t}.

Definition op_eq := (|Included_S|).(Compare.S.op_eq).

Definition op_ltgt := (|Included_S|).(Compare.S.op_ltgt).

Definition op_lt := (|Included_S|).(Compare.S.op_lt).

Definition op_lteq := (|Included_S|).(Compare.S.op_lteq).

Definition op_gteq := (|Included_S|).(Compare.S.op_gteq).

Definition op_gt := (|Included_S|).(Compare.S.op_gt).

Definition compare := (|Included_S|).(Compare.S.compare).

Definition equal := (|Included_S|).(Compare.S.equal).

Definition max := (|Included_S|).(Compare.S.max).

Definition min := (|Included_S|).(Compare.S.min).

Parameter encoding : Data_encoding.t period.

Parameter rpc_arg : RPC_arg.t period.

Parameter pp : Format.formatter -> period -> unit.

Parameter to_seconds : period -> int64.

Parameter of_seconds : int64 -> Error_monad.tzresult period.

Parameter of_seconds_exn : int64 -> period.

Parameter mult : int32 -> period -> Error_monad.tzresult period.

Parameter zero : period.

Parameter one_second : period.

Parameter one_minute : period.

Parameter one_hour : period.

Qty_repr

  • OCaml size: 337 lines
  • Coq size: 377 lines (+11% compared to OCaml)
qty_repr.ml 11 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type QTY = sig
  val id : string
end

module type S = sig
  type qty

  type error +=
    | Addition_overflow of qty * qty (* `Temporary *)
    | Subtraction_underflow of qty * qty (* `Temporary *)
    | Multiplication_overflow of qty * int64 (* `Temporary *)
    | Negative_multiplicator of qty * int64 (* `Temporary *)
    | Invalid_divisor of qty * int64

  (* `Temporary *)

  val id : string

  val zero : qty

  val one_mutez : qty

  val one_cent : qty

  val fifty_cents : qty

  val one : qty

  val ( -? ) : qty -> qty -> qty tzresult

  val ( +? ) : qty -> qty -> qty tzresult

  val ( *? ) : qty -> int64 -> qty tzresult

  val ( /? ) : qty -> int64 -> qty tzresult

  val to_mutez : qty -> int64

  (** [of_mutez n] (micro tez) is None if n is negative *)
  val of_mutez : int64 -> qty option

  (** [of_mutez_exn n] fails if n is negative.
      It should only be used at toplevel for constants. *)
  val of_mutez_exn : int64 -> qty

  (** It should only be used at toplevel for constants. *)
  val add_exn : qty -> qty -> qty

  (** It should only be used at toplevel for constants. *)
  val mul_exn : qty -> int -> qty

  val qty_encoding : qty Data_encoding.t

  val to_int64 : qty -> int64

  include Compare.S with type t := qty

  val pp : Format.formatter -> qty -> unit

  val of_string : string -> qty option

  val to_string : qty -> string
end

module Make (T : QTY) : S = struct
  type qty = int64 (* invariant: positive *)

  type error +=
    | Addition_overflow of qty * qty (* `Temporary *)
    | Subtraction_underflow of qty * qty (* `Temporary *)
    | Multiplication_overflow of qty * int64 (* `Temporary *)
    | Negative_multiplicator of qty * int64 (* `Temporary *)
    | Invalid_divisor of qty * int64

  (* `Temporary *)

  include Compare.Int64

  let zero = 0L

  (* all other constant are defined from the value of one micro tez *)
  let one_mutez = 1L

  let one_cent = Int64.mul one_mutez 10_000L

  let fifty_cents = Int64.mul one_cent 50L

  (* 1 tez = 100 cents = 1_000_000 mutez *)
  let one = Int64.mul one_cent 100L

  let id = T.id

  let of_string s =
    let triplets = function
      | hd :: tl ->
          let len = String.length hd in
          Compare.Int.(
            len <= 3 && len > 0
            && List.for_all (fun s -> String.length s = 3) tl)
      | [] ->
          false
    in
    let integers s = triplets (String.split_on_char ',' s) in
    let decimals s =
      let l = String.split_on_char ',' s in
      if Compare.Int.(List.length l > 2) then false else triplets (List.rev l)
    in
    let parse left right =
      let remove_commas s = String.concat "" (String.split_on_char ',' s) in
      let pad_to_six s =
        let len = String.length s in
        String.init 6 (fun i -> if Compare.Int.(i < len) then s.[i] else '0')
      in
      try
        Some
          (Int64.of_string
             (remove_commas left ^ pad_to_six (remove_commas right)))
      with _ -> None
    in
    match String.split_on_char '.' s with
    | [left; right] ->
        if String.contains s ',' then
          if integers left && decimals right then parse left right else None
        else if
          Compare.Int.(String.length right > 0)
          && Compare.Int.(String.length right <= 6)
        then parse left right
        else None
    | [left] ->
        if (not (String.contains s ',')) || integers left then parse left ""
        else None
    | _ ->
        None

  let pp ppf amount =
    let mult_int = 1_000_000L in
    let rec left ppf amount =
      let (d, r) = (Int64.(div amount 1000L), Int64.(rem amount 1000L)) in
      if d > 0L then Format.fprintf ppf "%a%03Ld" left d r
      else Format.fprintf ppf "%Ld" r
    in
    let right ppf amount =
      let triplet ppf v =
        if Compare.Int.(v mod 10 > 0) then Format.fprintf ppf "%03d" v
        else if Compare.Int.(v mod 100 > 0) then
          Format.fprintf ppf "%02d" (v / 10)
        else Format.fprintf ppf "%d" (v / 100)
      in
      let (hi, lo) = (amount / 1000, amount mod 1000) in
      if Compare.Int.(lo = 0) then Format.fprintf ppf "%a" triplet hi
      else Format.fprintf ppf "%03d%a" hi triplet lo
    in
    let (ints, decs) =
      (Int64.(div amount mult_int), Int64.(to_int (rem amount mult_int)))
    in
    Format.fprintf ppf "%a" left ints ;
    if Compare.Int.(decs > 0) then Format.fprintf ppf ".%a" right decs

  let to_string t = Format.asprintf "%a" pp t

  let ( - ) t1 t2 = if t2 <= t1 then Some (Int64.sub t1 t2) else None

  let ( -? ) t1 t2 =
    match t1 - t2 with
    | None ->
        error (Subtraction_underflow (t1, t2))
    | Some v ->
        ok v

  let ( +? ) t1 t2 =
    let t = Int64.add t1 t2 in
    if t < t1 then error (Addition_overflow (t1, t2)) else ok t

  let ( *? ) t m =
    let open Compare.Int64 in
    let open Int64 in
    let rec step cur pow acc =
      if cur = 0L then ok acc
      else
        pow +? pow
        >>? fun npow ->
        if logand cur 1L = 1L then
          acc +? pow >>? fun nacc -> step (shift_right_logical cur 1) npow nacc
        else step (shift_right_logical cur 1) npow acc
    in
    if m < 0L then error (Negative_multiplicator (t, m))
    else
      match step m t 0L with
      | Ok res ->
          Ok res
      | Error ([Addition_overflow _] as errs) ->
          Error (Multiplication_overflow (t, m) :: errs)
      | Error errs ->
          Error errs

  let ( /? ) t d =
    if d <= 0L then error (Invalid_divisor (t, d)) else ok (Int64.div t d)

  let add_exn t1 t2 =
    let t = Int64.add t1 t2 in
    if t <= 0L then invalid_arg "add_exn" else t

  let mul_exn t m =
    match t *? Int64.(of_int m) with
    | Ok v ->
        v
    | Error _ ->
        invalid_arg "mul_exn"

  let of_mutez t = if t < 0L then None else Some t

  let of_mutez_exn x =
    match of_mutez x with None -> invalid_arg "Qty.of_mutez" | Some v -> v

  let to_int64 t = t

  let to_mutez t = t

  let qty_encoding =
    let open Data_encoding in
    check_size 10 (conv Z.of_int64 (Json.wrap_error Z.to_int64) n)

  let () =
    let open Data_encoding in
    register_error_kind
      `Temporary
      ~id:(T.id ^ ".addition_overflow")
      ~title:("Overflowing " ^ T.id ^ " addition")
      ~pp:(fun ppf (opa, opb) ->
        Format.fprintf
          ppf
          "Overflowing addition of %a %s and %a %s"
          pp
          opa
          T.id
          pp
          opb
          T.id)
      ~description:("An addition of two " ^ T.id ^ " amounts overflowed")
      (obj1 (req "amounts" (tup2 qty_encoding qty_encoding)))
      (function Addition_overflow (a, b) -> Some (a, b) | _ -> None)
      (fun (a, b) -> Addition_overflow (a, b)) ;
    register_error_kind
      `Temporary
      ~id:(T.id ^ ".subtraction_underflow")
      ~title:("Underflowing " ^ T.id ^ " subtraction")
      ~pp:(fun ppf (opa, opb) ->
        Format.fprintf
          ppf
          "Underflowing subtraction of %a %s and %a %s"
          pp
          opa
          T.id
          pp
          opb
          T.id)
      ~description:("An subtraction of two " ^ T.id ^ " amounts underflowed")
      (obj1 (req "amounts" (tup2 qty_encoding qty_encoding)))
      (function Subtraction_underflow (a, b) -> Some (a, b) | _ -> None)
      (fun (a, b) -> Subtraction_underflow (a, b)) ;
    register_error_kind
      `Temporary
      ~id:(T.id ^ ".multiplication_overflow")
      ~title:("Overflowing " ^ T.id ^ " multiplication")
      ~pp:(fun ppf (opa, opb) ->
        Format.fprintf
          ppf
          "Overflowing multiplication of %a %s and %Ld"
          pp
          opa
          T.id
          opb)
      ~description:
        ("A multiplication of a " ^ T.id ^ " amount by an integer overflowed")
      (obj2 (req "amount" qty_encoding) (req "multiplicator" int64))
      (function Multiplication_overflow (a, b) -> Some (a, b) | _ -> None)
      (fun (a, b) -> Multiplication_overflow (a, b)) ;
    register_error_kind
      `Temporary
      ~id:(T.id ^ ".negative_multiplicator")
      ~title:("Negative " ^ T.id ^ " multiplicator")
      ~pp:(fun ppf (opa, opb) ->
        Format.fprintf
          ppf
          "Multiplication of %a %s by negative integer %Ld"
          pp
          opa
          T.id
          opb)
      ~description:
        ("Multiplication of a " ^ T.id ^ " amount by a negative integer")
      (obj2 (req "amount" qty_encoding) (req "multiplicator" int64))
      (function Negative_multiplicator (a, b) -> Some (a, b) | _ -> None)
      (fun (a, b) -> Negative_multiplicator (a, b)) ;
    register_error_kind
      `Temporary
      ~id:(T.id ^ ".invalid_divisor")
      ~title:("Invalid " ^ T.id ^ " divisor")
      ~pp:(fun ppf (opa, opb) ->
        Format.fprintf
          ppf
          "Division of %a %s by non positive integer %Ld"
          pp
          opa
          T.id
          opb)
      ~description:
        ("Multiplication of a " ^ T.id ^ " amount by a non positive integer")
      (obj2 (req "amount" qty_encoding) (req "divisor" int64))
      (function Invalid_divisor (a, b) -> Some (a, b) | _ -> None)
      (fun (a, b) -> Invalid_divisor (a, b))
end
Qty_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Module QTY.
  Record signature := {
    id : string;
  }.
End QTY.

Module S.
  Record signature {qty : Set} := {
    qty := qty;
    (* extensible_type error *)
    id : string;
    zero : qty;
    one_mutez : qty;
    one_cent : qty;
    fifty_cents : qty;
    one : qty;
    op_minusquestion : qty -> qty -> Error_monad.tzresult qty;
    op_plusquestion : qty -> qty -> Error_monad.tzresult qty;
    op_starquestion : qty -> int64 -> Error_monad.tzresult qty;
    op_divquestion : qty -> int64 -> Error_monad.tzresult qty;
    to_mutez : qty -> int64;
    of_mutez : int64 -> option qty;
    of_mutez_exn : int64 -> qty;
    add_exn : qty -> qty -> qty;
    mul_exn : qty -> Z -> qty;
    qty_encoding : Data_encoding.t qty;
    to_int64 : qty -> int64;
    op_eq : qty -> qty -> bool;
    op_ltgt : qty -> qty -> bool;
    op_lt : qty -> qty -> bool;
    op_lteq : qty -> qty -> bool;
    op_gteq : qty -> qty -> bool;
    op_gt : qty -> qty -> bool;
    compare : qty -> qty -> Z;
    equal : qty -> qty -> bool;
    max : qty -> qty -> qty;
    min : qty -> qty -> qty;
    pp : Format.formatter -> qty -> unit;
    of_string : string -> option qty;
    to_string : qty -> string;
  }.
  Arguments signature : clear implicits.
End S.

Definition Make :=
  fun (T : {_ : unit & QTY.signature}) =>
    (let qty := int64 in
    (* ❌ type_extension *)
    let t := (|Compare.Int64|).(Compare.S.t) in
    let op_eq := (|Compare.Int64|).(Compare.S.op_eq) in
    let op_ltgt := (|Compare.Int64|).(Compare.S.op_ltgt) in
    let op_lt := (|Compare.Int64|).(Compare.S.op_lt) in
    let op_lteq := (|Compare.Int64|).(Compare.S.op_lteq) in
    let op_gteq := (|Compare.Int64|).(Compare.S.op_gteq) in
    let op_gt := (|Compare.Int64|).(Compare.S.op_gt) in
    let compare := (|Compare.Int64|).(Compare.S.compare) in
    let equal := (|Compare.Int64|).(Compare.S.equal) in
    let max := (|Compare.Int64|).(Compare.S.max) in
    let min := (|Compare.Int64|).(Compare.S.min) in
    let zero :=
      (* ❌ Constant of type int64 is converted to int *)
      0 in
    let one_mutez :=
      (* ❌ Constant of type int64 is converted to int *)
      1 in
    let one_cent :=
      Int64.mul one_mutez
        (* ❌ Constant of type int64 is converted to int *)
        10000 in
    let fifty_cents :=
      Int64.mul one_cent
        (* ❌ Constant of type int64 is converted to int *)
        50 in
    let one :=
      Int64.mul one_cent
        (* ❌ Constant of type int64 is converted to int *)
        100 in
    let id := (|T|).(QTY.id) in
    let of_string (s : string) : option int64 :=
      let triplets (function_parameter : list string) : bool :=
        match function_parameter with
        | cons hd tl =>
          let len := String.length hd in
          Pervasives.op_andand ((|Compare.Int|).(Compare.S.op_lteq) len 3)
            (Pervasives.op_andand ((|Compare.Int|).(Compare.S.op_gt) len 0)
              (List.for_all
                (fun s => (|Compare.Int|).(Compare.S.op_eq) (String.length s) 3)
                tl))
        | [] => false
        end in
      let integers (s : string) : bool :=
        triplets (String.split_on_char "," % char s) in
      let decimals (s : string) : bool :=
        let l := String.split_on_char "," % char s in
        if (|Compare.Int|).(Compare.S.op_gt) (List.length l) 2 then
          false
        else
          triplets (List.rev l) in
      let parse (__left : string) (__right : string) : option int64 :=
        let remove_commas (s : string) : string :=
          String.concat "" (String.split_on_char "," % char s) in
        let pad_to_six (s : string) : string :=
          let len := String.length s in
          String.init 6
            (fun i =>
              if (|Compare.Int|).(Compare.S.op_lt) i len then
                String.get s i
              else
                "0" % char) in
        (* ❌ Try-with are not handled *)
        try
          (Some
            (Int64.of_string
              (Pervasives.op_caret (remove_commas __left)
                (pad_to_six (remove_commas __right))))) in
      match String.split_on_char "." % char s with
      | cons __left (cons __right []) =>
        if String.contains s "," % char then
          if Pervasives.op_andand (integers __left) (decimals __right) then
            parse __left __right
          else
            None
        else
          if
            Pervasives.op_andand
              ((|Compare.Int|).(Compare.S.op_gt) (String.length __right) 0)
              ((|Compare.Int|).(Compare.S.op_lteq) (String.length __right) 6)
            then
            parse __left __right
          else
            None
      | cons __left [] =>
        if
          Pervasives.op_pipepipe (Pervasives.not (String.contains s "," % char))
            (integers __left) then
          parse __left ""
        else
          None
      | _ => None
      end in
    let pp (ppf : Format.formatter) (amount : int64) : unit :=
      let mult_int :=
        (* ❌ Constant of type int64 is converted to int *)
        1000000 in
      let fix __left (ppf : Format.formatter) (amount : int64) {struct ppf}
        : unit :=
        let '(d, r) :=
          ((Int64.div amount
            (* ❌ Constant of type int64 is converted to int *)
            1000),
            (Int64.rem amount
              (* ❌ Constant of type int64 is converted to int *)
              1000)) in
        if
          op_gt d
            (* ❌ Constant of type int64 is converted to int *)
            0 then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Int64 CamlinternalFormatBasics.Int_d
                  (CamlinternalFormatBasics.Lit_padding
                    CamlinternalFormatBasics.Zeros 3)
                  CamlinternalFormatBasics.No_precision
                  CamlinternalFormatBasics.End_of_format)) "%a%03Ld") __left d r
        else
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Int64 CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                CamlinternalFormatBasics.End_of_format) "%Ld") r in
      let __right (ppf : Format.formatter) (amount : Z) : unit :=
        let triplet (ppf : Format.formatter) (v : Z) : unit :=
          if (|Compare.Int|).(Compare.S.op_gt) (Pervasives.__mod v 10) 0 then
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  (CamlinternalFormatBasics.Lit_padding
                    CamlinternalFormatBasics.Zeros 3)
                  CamlinternalFormatBasics.No_precision
                  CamlinternalFormatBasics.End_of_format) "%03d") v
          else
            if (|Compare.Int|).(Compare.S.op_gt) (Pervasives.__mod v 100) 0 then
              Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    (CamlinternalFormatBasics.Lit_padding
                      CamlinternalFormatBasics.Zeros 2)
                    CamlinternalFormatBasics.No_precision
                    CamlinternalFormatBasics.End_of_format) "%02d")
                (Pervasives.op_div v 10)
            else
              Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    CamlinternalFormatBasics.End_of_format) "%d")
                (Pervasives.op_div v 100) in
        let '(hi, lo) :=
          ((Pervasives.op_div amount 1000), (Pervasives.__mod amount 1000)) in
        if (|Compare.Int|).(Compare.S.op_eq) lo 0 then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format) "%a") triplet hi
        else
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                (CamlinternalFormatBasics.Lit_padding
                  CamlinternalFormatBasics.Zeros 3)
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format)) "%03d%a") hi triplet
            lo in
      let '(ints, decs) :=
        ((Int64.div amount mult_int), (Int64.to_int (Int64.rem amount mult_int)))
        in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      (* ❌ instruction_sequence ";" *)
      if (|Compare.Int|).(Compare.S.op_gt) decs 0 then
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char_literal "." % char
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format)) ".%a") __right decs
      else
        tt in
    let to_string (__t_value : int64) : string :=
      Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
          "%a") pp __t_value in
    let op_minus (t1 : t) (t2 : t) : option int64 :=
      if op_lteq t2 t1 then
        Some (Int64.sub t1 t2)
      else
        None in
    let op_minusquestion (t1 : t) (t2 : t) : Error_monad.tzresult int64 :=
      match op_minus t1 t2 with
      | None => Error_monad.__error_value extensible_type_value
      | Some v => Error_monad.ok v
      end in
    let op_plusquestion (t1 : t) (t2 : qty) : Error_monad.tzresult int64 :=
      let __t_value := Int64.add t1 t2 in
      if op_lt __t_value t1 then
        Error_monad.__error_value extensible_type_value
      else
        Error_monad.ok __t_value in
    let op_starquestion (__t_value : qty) (m : (|Compare.Int64|).(Compare.S.t))
      : Error_monad.tzresult t :=
      let fix step (cur : (|Compare.Int64|).(Compare.S.t)) (pow : t) (acc : t)
        {struct cur} : Error_monad.tzresult t :=
        if
          (|Compare.Int64|).(Compare.S.op_eq) cur
            (* ❌ Constant of type int64 is converted to int *)
            0 then
          Error_monad.ok acc
        else
          Error_monad.op_gtgtquestion (op_plusquestion pow pow)
            (fun npow =>
              if
                (|Compare.Int64|).(Compare.S.op_eq)
                  (Int64.logand cur
                    (* ❌ Constant of type int64 is converted to int *)
                    1)
                  (* ❌ Constant of type int64 is converted to int *)
                  1 then
                Error_monad.op_gtgtquestion (op_plusquestion acc pow)
                  (fun nacc => step (Int64.shift_right_logical cur 1) npow nacc)
              else
                step (Int64.shift_right_logical cur 1) npow acc) in
      if
        (|Compare.Int64|).(Compare.S.op_lt) m
          (* ❌ Constant of type int64 is converted to int *)
          0 then
        Error_monad.__error_value extensible_type_value
      else
        match
          step m __t_value
            (* ❌ Constant of type int64 is converted to int *)
            0 with
        | Pervasives.Ok res => Pervasives.Ok res
        | Pervasives.Error errs => Pervasives.Error errs
        end in
    let op_divquestion (__t_value : qty) (d : t) : Error_monad.tzresult int64 :=
      if
        op_lteq d
          (* ❌ Constant of type int64 is converted to int *)
          0 then
        Error_monad.__error_value extensible_type_value
      else
        Error_monad.ok (Int64.div __t_value d) in
    let add_exn (t1 : int64) (t2 : int64) : int64 :=
      let __t_value := Int64.add t1 t2 in
      if
        op_lteq __t_value
          (* ❌ Constant of type int64 is converted to int *)
          0 then
        Pervasives.invalid_arg "add_exn"
      else
        __t_value in
    let mul_exn (__t_value : qty) (m : Z) : t :=
      match op_starquestion __t_value (Int64.of_int m) with
      | Pervasives.Ok v => v
      | Pervasives.Error _ => Pervasives.invalid_arg "mul_exn"
      end in
    let of_mutez (__t_value : t) : option t :=
      if
        op_lt __t_value
          (* ❌ Constant of type int64 is converted to int *)
          0 then
        None
      else
        Some __t_value in
    let of_mutez_exn (x : t) : t :=
      match of_mutez x with
      | None => Pervasives.invalid_arg "Qty.of_mutez"
      | Some v => v
      end in
    let to_int64 {A : Set} (__t_value : A) : A :=
      __t_value in
    let to_mutez {A : Set} (__t_value : A) : A :=
      __t_value in
    let qty_encoding :=
      Data_encoding.check_size 10
        (Data_encoding.conv Z.of_int64
          (Data_encoding.Json.wrap_error Z.to_int64) None Data_encoding.n) in
    (* ❌ top_level_evaluation *)
    existT _ _
      {|
        S.id := id;
        S.zero := zero;
        S.one_mutez := one_mutez;
        S.one_cent := one_cent;
        S.fifty_cents := fifty_cents;
        S.one := one;
        S.op_minusquestion := op_minusquestion;
        S.op_plusquestion := op_plusquestion;
        S.op_starquestion := op_starquestion;
        S.op_divquestion := op_divquestion;
        S.to_mutez := to_mutez;
        S.of_mutez := of_mutez;
        S.of_mutez_exn := of_mutez_exn;
        S.add_exn := add_exn;
        S.mul_exn := mul_exn;
        S.qty_encoding := qty_encoding;
        S.to_int64 := to_int64;
        S.op_eq := op_eq;
        S.op_ltgt := op_ltgt;
        S.op_lt := op_lt;
        S.op_lteq := op_lteq;
        S.op_gteq := op_gteq;
        S.op_gt := op_gt;
        S.compare := compare;
        S.equal := equal;
        S.max := max;
        S.min := min;
        S.pp := pp;
        S.of_string := of_string;
        S.to_string := to_string
      |} : {qty : _ & S.signature qty}).

Raw_context

  • OCaml size: 754 lines
  • Coq size: 1030 lines (+36% compared to OCaml)
raw_context.ml 42 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Int_set = Set.Make (Compare.Int)

type t = {
  context : Context.t;
  constants : Constants_repr.parametric;
  first_level : Raw_level_repr.t;
  level : Level_repr.t;
  predecessor_timestamp : Time.t;
  timestamp : Time.t;
  fitness : Int64.t;
  deposits : Tez_repr.t Signature.Public_key_hash.Map.t;
  included_endorsements : int;
  allowed_endorsements :
    (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t;
  fees : Tez_repr.t;
  rewards : Tez_repr.t;
  block_gas : Z.t;
  operation_gas : Gas_limit_repr.t;
  internal_gas : Gas_limit_repr.internal_gas;
  storage_space_to_pay : Z.t option;
  allocated_contracts : int option;
  origination_nonce : Contract_repr.origination_nonce option;
  temporary_big_map : Z.t;
  internal_nonce : int;
  internal_nonces_used : Int_set.t;
}

type context = t

type root_context = t

let current_level ctxt = ctxt.level

let predecessor_timestamp ctxt = ctxt.predecessor_timestamp

let current_timestamp ctxt = ctxt.timestamp

let current_fitness ctxt = ctxt.fitness

let first_level ctxt = ctxt.first_level

let constants ctxt = ctxt.constants

let recover ctxt = ctxt.context

let record_endorsement ctxt k =
  match Signature.Public_key_hash.Map.find_opt k ctxt.allowed_endorsements with
  | None ->
      assert false
  | Some (_, _, true) ->
      assert false (* right already used *)
  | Some (d, s, false) ->
      {
        ctxt with
        included_endorsements = ctxt.included_endorsements + List.length s;
        allowed_endorsements =
          Signature.Public_key_hash.Map.add
            k
            (d, s, true)
            ctxt.allowed_endorsements;
      }

let init_endorsements ctxt allowed_endorsements =
  if Signature.Public_key_hash.Map.is_empty allowed_endorsements then
    assert false (* can't initialize to empty *)
  else if Signature.Public_key_hash.Map.is_empty ctxt.allowed_endorsements then
    {ctxt with allowed_endorsements}
  else assert false

(* can't initialize twice *)

let allowed_endorsements ctxt = ctxt.allowed_endorsements

let included_endorsements ctxt = ctxt.included_endorsements

type error += Too_many_internal_operations (* `Permanent *)

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"too_many_internal_operations"
    ~title:"Too many internal operations"
    ~description:
      "A transaction exceeded the hard limit of internal operations it can emit"
    empty
    (function Too_many_internal_operations -> Some () | _ -> None)
    (fun () -> Too_many_internal_operations)

let fresh_internal_nonce ctxt =
  if Compare.Int.(ctxt.internal_nonce >= 65_535) then
    error Too_many_internal_operations
  else
    ok
      ( {ctxt with internal_nonce = ctxt.internal_nonce + 1},
        ctxt.internal_nonce )

let reset_internal_nonce ctxt =
  {ctxt with internal_nonces_used = Int_set.empty; internal_nonce = 0}

let record_internal_nonce ctxt k =
  {ctxt with internal_nonces_used = Int_set.add k ctxt.internal_nonces_used}

let internal_nonce_already_recorded ctxt k =
  Int_set.mem k ctxt.internal_nonces_used

let set_current_fitness ctxt fitness = {ctxt with fitness}

let add_fees ctxt fees =
  Lwt.return Tez_repr.(ctxt.fees +? fees)
  >>=? fun fees -> return {ctxt with fees}

let add_rewards ctxt rewards =
  Lwt.return Tez_repr.(ctxt.rewards +? rewards)
  >>=? fun rewards -> return {ctxt with rewards}

let add_deposit ctxt delegate deposit =
  let previous =
    match Signature.Public_key_hash.Map.find_opt delegate ctxt.deposits with
    | Some tz ->
        tz
    | None ->
        Tez_repr.zero
  in
  Lwt.return Tez_repr.(previous +? deposit)
  >>=? fun deposit ->
  let deposits =
    Signature.Public_key_hash.Map.add delegate deposit ctxt.deposits
  in
  return {ctxt with deposits}

let get_deposits ctxt = ctxt.deposits

let get_rewards ctxt = ctxt.rewards

let get_fees ctxt = ctxt.fees

type error += Undefined_operation_nonce (* `Permanent *)

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"undefined_operation_nonce"
    ~title:"Ill timed access to the origination nonce"
    ~description:
      "An origination was attemped out of the scope of a manager operation"
    empty
    (function Undefined_operation_nonce -> Some () | _ -> None)
    (fun () -> Undefined_operation_nonce)

let init_origination_nonce ctxt operation_hash =
  let origination_nonce =
    Some (Contract_repr.initial_origination_nonce operation_hash)
  in
  {ctxt with origination_nonce}

let origination_nonce ctxt =
  match ctxt.origination_nonce with
  | None ->
      error Undefined_operation_nonce
  | Some origination_nonce ->
      ok origination_nonce

let increment_origination_nonce ctxt =
  match ctxt.origination_nonce with
  | None ->
      error Undefined_operation_nonce
  | Some cur_origination_nonce ->
      let origination_nonce =
        Some (Contract_repr.incr_origination_nonce cur_origination_nonce)
      in
      ok ({ctxt with origination_nonce}, cur_origination_nonce)

let unset_origination_nonce ctxt = {ctxt with origination_nonce = None}

type error += Gas_limit_too_high (* `Permanent *)

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"gas_limit_too_high"
    ~title:"Gas limit out of protocol hard bounds"
    ~description:"A transaction tried to exceed the hard limit on gas"
    empty
    (function Gas_limit_too_high -> Some () | _ -> None)
    (fun () -> Gas_limit_too_high)

let check_gas_limit ctxt remaining =
  if
    Compare.Z.(remaining > ctxt.constants.hard_gas_limit_per_operation)
    || Compare.Z.(remaining < Z.zero)
  then error Gas_limit_too_high
  else ok ()

let set_gas_limit ctxt remaining =
  {
    ctxt with
    operation_gas = Limited {remaining};
    internal_gas = Gas_limit_repr.internal_gas_zero;
  }

let set_gas_unlimited ctxt = {ctxt with operation_gas = Unaccounted}

let consume_gas ctxt cost =
  Gas_limit_repr.consume
    ctxt.block_gas
    ctxt.operation_gas
    ctxt.internal_gas
    cost
  >>? fun (block_gas, operation_gas, internal_gas) ->
  ok {ctxt with block_gas; operation_gas; internal_gas}

let check_enough_gas ctxt cost =
  Gas_limit_repr.check_enough
    ctxt.block_gas
    ctxt.operation_gas
    ctxt.internal_gas
    cost

let gas_level ctxt = ctxt.operation_gas

let block_gas_level ctxt = ctxt.block_gas

let gas_consumed ~since ~until =
  match (gas_level since, gas_level until) with
  | (Limited {remaining = before}, Limited {remaining = after}) ->
      Z.sub before after
  | (_, _) ->
      Z.zero

let init_storage_space_to_pay ctxt =
  match ctxt.storage_space_to_pay with
  | Some _ ->
      assert false
  | None ->
      {
        ctxt with
        storage_space_to_pay = Some Z.zero;
        allocated_contracts = Some 0;
      }

let update_storage_space_to_pay ctxt n =
  match ctxt.storage_space_to_pay with
  | None ->
      assert false
  | Some storage_space_to_pay ->
      {ctxt with storage_space_to_pay = Some (Z.add n storage_space_to_pay)}

let update_allocated_contracts_count ctxt =
  match ctxt.allocated_contracts with
  | None ->
      assert false
  | Some allocated_contracts ->
      {ctxt with allocated_contracts = Some (succ allocated_contracts)}

let clear_storage_space_to_pay ctxt =
  match (ctxt.storage_space_to_pay, ctxt.allocated_contracts) with
  | (None, _) | (_, None) ->
      assert false
  | (Some storage_space_to_pay, Some allocated_contracts) ->
      ( {ctxt with storage_space_to_pay = None; allocated_contracts = None},
        storage_space_to_pay,
        allocated_contracts )

type missing_key_kind = [`Get | `Set | `Del | `Copy]

type storage_error =
  | Incompatible_protocol_version of string
  | Missing_key of string list * missing_key_kind
  | Existing_key of string list
  | Corrupted_data of string list

let storage_error_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Incompatible_protocol_version"
        (obj1 (req "incompatible_protocol_version" string))
        (function Incompatible_protocol_version arg -> Some arg | _ -> None)
        (fun arg -> Incompatible_protocol_version arg);
      case
        (Tag 1)
        ~title:"Missing_key"
        (obj2
           (req "missing_key" (list string))
           (req
              "function"
              (string_enum
                 [("get", `Get); ("set", `Set); ("del", `Del); ("copy", `Copy)])))
        (function Missing_key (key, f) -> Some (key, f) | _ -> None)
        (fun (key, f) -> Missing_key (key, f));
      case
        (Tag 2)
        ~title:"Existing_key"
        (obj1 (req "existing_key" (list string)))
        (function Existing_key key -> Some key | _ -> None)
        (fun key -> Existing_key key);
      case
        (Tag 3)
        ~title:"Corrupted_data"
        (obj1 (req "corrupted_data" (list string)))
        (function Corrupted_data key -> Some key | _ -> None)
        (fun key -> Corrupted_data key) ]

let pp_storage_error ppf = function
  | Incompatible_protocol_version version ->
      Format.fprintf
        ppf
        "Found a context with an unexpected version '%s'."
        version
  | Missing_key (key, `Get) ->
      Format.fprintf ppf "Missing key '%s'." (String.concat "/" key)
  | Missing_key (key, `Set) ->
      Format.fprintf
        ppf
        "Cannot set undefined key '%s'."
        (String.concat "/" key)
  | Missing_key (key, `Del) ->
      Format.fprintf
        ppf
        "Cannot delete undefined key '%s'."
        (String.concat "/" key)
  | Missing_key (key, `Copy) ->
      Format.fprintf
        ppf
        "Cannot copy undefined key '%s'."
        (String.concat "/" key)
  | Existing_key key ->
      Format.fprintf
        ppf
        "Cannot initialize defined key '%s'."
        (String.concat "/" key)
  | Corrupted_data key ->
      Format.fprintf
        ppf
        "Failed to parse the data at '%s'."
        (String.concat "/" key)

type error += Storage_error of storage_error

let () =
  register_error_kind
    `Permanent
    ~id:"context.storage_error"
    ~title:"Storage error (fatal internal error)"
    ~description:
      "An error that should never happen unless something has been deleted or \
       corrupted in the database."
    ~pp:(fun ppf err ->
      Format.fprintf ppf "@[<v 2>Storage error:@ %a@]" pp_storage_error err)
    storage_error_encoding
    (function Storage_error err -> Some err | _ -> None)
    (fun err -> Storage_error err)

let storage_error err = fail (Storage_error err)

(* Initialization *********************************************************)

(* This key should always be populated for every version of the
   protocol.  It's absence meaning that the context is empty. *)
let version_key = ["version"]

let version_value = "alpha_current"

let version = "v1"

let first_level_key = [version; "first_level"]

let constants_key = [version; "constants"]

let protocol_param_key = ["protocol_parameters"]

let get_first_level ctxt =
  Context.get ctxt first_level_key
  >>= function
  | None ->
      storage_error (Missing_key (first_level_key, `Get))
  | Some bytes -> (
    match Data_encoding.Binary.of_bytes Raw_level_repr.encoding bytes with
    | None ->
        storage_error (Corrupted_data first_level_key)
    | Some level ->
        return level )

let set_first_level ctxt level =
  let bytes =
    Data_encoding.Binary.to_bytes_exn Raw_level_repr.encoding level
  in
  Context.set ctxt first_level_key bytes >>= fun ctxt -> return ctxt

type error += Failed_to_parse_parameter of MBytes.t

type error += Failed_to_decode_parameter of Data_encoding.json * string

let () =
  register_error_kind
    `Temporary
    ~id:"context.failed_to_parse_parameter"
    ~title:"Failed to parse parameter"
    ~description:"The protocol parameters are not valid JSON."
    ~pp:(fun ppf bytes ->
      Format.fprintf
        ppf
        "@[<v 2>Cannot parse the protocol parameter:@ %s@]"
        (MBytes.to_string bytes))
    Data_encoding.(obj1 (req "contents" bytes))
    (function Failed_to_parse_parameter data -> Some data | _ -> None)
    (fun data -> Failed_to_parse_parameter data) ;
  register_error_kind
    `Temporary
    ~id:"context.failed_to_decode_parameter"
    ~title:"Failed to decode parameter"
    ~description:"Unexpected JSON object."
    ~pp:(fun ppf (json, msg) ->
      Format.fprintf
        ppf
        "@[<v 2>Cannot decode the protocol parameter:@ %s@ %a@]"
        msg
        Data_encoding.Json.pp
        json)
    Data_encoding.(obj2 (req "contents" json) (req "error" string))
    (function
      | Failed_to_decode_parameter (json, msg) -> Some (json, msg) | _ -> None)
    (fun (json, msg) -> Failed_to_decode_parameter (json, msg))

let get_proto_param ctxt =
  Context.get ctxt protocol_param_key
  >>= function
  | None ->
      failwith "Missing protocol parameters."
  | Some bytes -> (
    match Data_encoding.Binary.of_bytes Data_encoding.json bytes with
    | None ->
        fail (Failed_to_parse_parameter bytes)
    | Some json -> (
        Context.del ctxt protocol_param_key
        >>= fun ctxt ->
        match Data_encoding.Json.destruct Parameters_repr.encoding json with
        | exception (Data_encoding.Json.Cannot_destruct _ as exn) ->
            Format.kasprintf
              failwith
              "Invalid protocol_parameters: %a %a"
              (fun ppf -> Data_encoding.Json.print_error ppf)
              exn
              Data_encoding.Json.pp
              json
        | param ->
            return (param, ctxt) ) )

let set_constants ctxt constants =
  let bytes =
    Data_encoding.Binary.to_bytes_exn
      Constants_repr.parametric_encoding
      constants
  in
  Context.set ctxt constants_key bytes

let get_constants ctxt =
  Context.get ctxt constants_key
  >>= function
  | None ->
      failwith "Internal error: cannot read constants in context."
  | Some bytes -> (
    match
      Data_encoding.Binary.of_bytes Constants_repr.parametric_encoding bytes
    with
    | None ->
        failwith "Internal error: cannot parse constants in context."
    | Some constants ->
        return constants )

let patch_constants ctxt f =
  let constants = f ctxt.constants in
  set_constants ctxt.context constants
  >>= fun context -> Lwt.return {ctxt with context; constants}

let check_inited ctxt =
  Context.get ctxt version_key
  >>= function
  | None ->
      failwith "Internal error: un-initialized context."
  | Some bytes ->
      let s = MBytes.to_string bytes in
      if Compare.String.(s = version_value) then return_unit
      else storage_error (Incompatible_protocol_version s)

let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt =
  Lwt.return (Raw_level_repr.of_int32 level)
  >>=? fun level ->
  Lwt.return (Fitness_repr.to_int64 fitness)
  >>=? fun fitness ->
  check_inited ctxt
  >>=? fun () ->
  get_constants ctxt
  >>=? fun constants ->
  get_first_level ctxt
  >>=? fun first_level ->
  let level =
    Level_repr.from_raw
      ~first_level
      ~blocks_per_cycle:constants.Constants_repr.blocks_per_cycle
      ~blocks_per_voting_period:
        constants.Constants_repr.blocks_per_voting_period
      ~blocks_per_commitment:constants.Constants_repr.blocks_per_commitment
      level
  in
  return
    {
      context = ctxt;
      constants;
      level;
      predecessor_timestamp;
      timestamp;
      fitness;
      first_level;
      allowed_endorsements = Signature.Public_key_hash.Map.empty;
      included_endorsements = 0;
      fees = Tez_repr.zero;
      rewards = Tez_repr.zero;
      deposits = Signature.Public_key_hash.Map.empty;
      operation_gas = Unaccounted;
      internal_gas = Gas_limit_repr.internal_gas_zero;
      storage_space_to_pay = None;
      allocated_contracts = None;
      block_gas = constants.Constants_repr.hard_gas_limit_per_block;
      origination_nonce = None;
      temporary_big_map = Z.sub Z.zero Z.one;
      internal_nonce = 0;
      internal_nonces_used = Int_set.empty;
    }

type previous_protocol = Genesis of Parameters_repr.t | Alpha_previous

let check_and_update_protocol_version ctxt =
  Context.get ctxt version_key
  >>= (function
        | None ->
            failwith
              "Internal error: un-initialized context in check_first_block."
        | Some bytes ->
            let s = MBytes.to_string bytes in
            if Compare.String.(s = version_value) then
              failwith "Internal error: previously initialized context."
            else if Compare.String.(s = "genesis") then
              get_proto_param ctxt
              >>=? fun (param, ctxt) -> return (Genesis param, ctxt)
            else if Compare.String.(s = "alpha_previous") then
              return (Alpha_previous, ctxt)
            else storage_error (Incompatible_protocol_version s))
  >>=? fun (previous_proto, ctxt) ->
  Context.set ctxt version_key (MBytes.of_string version_value)
  >>= fun ctxt -> return (previous_proto, ctxt)

let prepare_first_block ~level ~timestamp ~fitness ctxt =
  check_and_update_protocol_version ctxt
  >>=? fun (previous_proto, ctxt) ->
  ( match previous_proto with
  | Genesis param ->
      Lwt.return (Raw_level_repr.of_int32 level)
      >>=? fun first_level ->
      set_first_level ctxt first_level
      >>=? fun ctxt ->
      set_constants ctxt param.constants >>= fun ctxt -> return ctxt
  | Alpha_previous ->
      return ctxt )
  >>=? fun ctxt ->
  prepare ctxt ~level ~predecessor_timestamp:timestamp ~timestamp ~fitness
  >>=? fun ctxt -> return (previous_proto, ctxt)

let activate ({context = c; _} as s) h =
  Updater.activate c h >>= fun c -> Lwt.return {s with context = c}

let fork_test_chain ({context = c; _} as s) protocol expiration =
  Updater.fork_test_chain c ~protocol ~expiration
  >>= fun c -> Lwt.return {s with context = c}

(* Generic context ********************************************************)

type key = string list

type value = MBytes.t

module type T = sig
  type t

  type context = t

  val mem : context -> key -> bool Lwt.t

  val dir_mem : context -> key -> bool Lwt.t

  val get : context -> key -> value tzresult Lwt.t

  val get_option : context -> key -> value option Lwt.t

  val init : context -> key -> value -> context tzresult Lwt.t

  val set : context -> key -> value -> context tzresult Lwt.t

  val init_set : context -> key -> value -> context Lwt.t

  val set_option : context -> key -> value option -> context Lwt.t

  val delete : context -> key -> context tzresult Lwt.t

  val remove : context -> key -> context Lwt.t

  val remove_rec : context -> key -> context Lwt.t

  val copy : context -> from:key -> to_:key -> context tzresult Lwt.t

  val fold :
    context ->
    key ->
    init:'a ->
    f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) ->
    'a Lwt.t

  val keys : context -> key -> key list Lwt.t

  val fold_keys :
    context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  val project : context -> root_context

  val absolute_key : context -> key -> key

  val consume_gas : context -> Gas_limit_repr.cost -> context tzresult

  val check_enough_gas : context -> Gas_limit_repr.cost -> unit tzresult

  val description : context Storage_description.t
end

let mem ctxt k = Context.mem ctxt.context k

let dir_mem ctxt k = Context.dir_mem ctxt.context k

let get ctxt k =
  Context.get ctxt.context k
  >>= function
  | None -> storage_error (Missing_key (k, `Get)) | Some v -> return v

let get_option ctxt k = Context.get ctxt.context k

(* Verify that the k is present before modifying *)
let set ctxt k v =
  Context.mem ctxt.context k
  >>= function
  | false ->
      storage_error (Missing_key (k, `Set))
  | true ->
      Context.set ctxt.context k v
      >>= fun context -> return {ctxt with context}

(* Verify that the k is not present before inserting *)
let init ctxt k v =
  Context.mem ctxt.context k
  >>= function
  | true ->
      storage_error (Existing_key k)
  | false ->
      Context.set ctxt.context k v
      >>= fun context -> return {ctxt with context}

(* Does not verify that the key is present or not *)
let init_set ctxt k v =
  Context.set ctxt.context k v
  >>= fun context -> Lwt.return {ctxt with context}

(* Verify that the key is present before deleting *)
let delete ctxt k =
  Context.mem ctxt.context k
  >>= function
  | false ->
      storage_error (Missing_key (k, `Del))
  | true ->
      Context.del ctxt.context k >>= fun context -> return {ctxt with context}

(* Do not verify before deleting *)
let remove ctxt k =
  Context.del ctxt.context k >>= fun context -> Lwt.return {ctxt with context}

let set_option ctxt k = function
  | None ->
      remove ctxt k
  | Some v ->
      init_set ctxt k v

let remove_rec ctxt k =
  Context.remove_rec ctxt.context k
  >>= fun context -> Lwt.return {ctxt with context}

let copy ctxt ~from ~to_ =
  Context.copy ctxt.context ~from ~to_
  >>= function
  | None ->
      storage_error (Missing_key (from, `Copy))
  | Some context ->
      return {ctxt with context}

let fold ctxt k ~init ~f = Context.fold ctxt.context k ~init ~f

let keys ctxt k = Context.keys ctxt.context k

let fold_keys ctxt k ~init ~f = Context.fold_keys ctxt.context k ~init ~f

let project x = x

let absolute_key _ k = k

let[@coq_axiom] description = Storage_description.create ()

let fresh_temporary_big_map ctxt =
  ( {ctxt with temporary_big_map = Z.sub ctxt.temporary_big_map Z.one},
    ctxt.temporary_big_map )

let reset_temporary_big_map ctxt =
  {ctxt with temporary_big_map = Z.sub Z.zero Z.one}

let temporary_big_maps ctxt f acc =
  let rec iter acc id =
    if Z.equal id ctxt.temporary_big_map then Lwt.return acc
    else f acc id >>= fun acc -> iter acc (Z.sub id Z.one)
  in
  iter acc (Z.sub Z.zero Z.one)
Raw_context.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Constants_repr.
Require Tezos.Contract_repr.
Require Tezos.Fitness_repr.
Require Tezos.Gas_limit_repr.
Require Tezos.Level_repr.
Require Tezos.Parameters_repr.
Require Tezos.Raw_level_repr.
Require Tezos.Storage_description.
Require Tezos.Tez_repr.

Definition Int_set :=
  __Set.Make
    (existT _ _
      {|
        Compare.COMPARABLE.compare := (|Compare.Int|).(Compare.S.compare)
      |}).

Module t.
  Record record := Build {
    context : Context.t;
    constants : Constants_repr.parametric;
    first_level : Raw_level_repr.t;
    level : Level_repr.t;
    predecessor_timestamp : Time.t;
    timestamp : Time.t;
    fitness : Int64.t;
    deposits :
      (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.t)
        Tez_repr.t;
    included_endorsements : Z;
    allowed_endorsements :
      (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.t)
        ((|Signature.Public_key|).(S.SPublic_key.t) * list Z * bool);
    fees : Tez_repr.t;
    rewards : Tez_repr.t;
    block_gas : Z.t;
    operation_gas : Gas_limit_repr.t;
    internal_gas : Gas_limit_repr.internal_gas;
    storage_space_to_pay : option Z.t;
    allocated_contracts : option Z;
    origination_nonce : option Contract_repr.origination_nonce;
    temporary_big_map : Z.t;
    internal_nonce : Z;
    internal_nonces_used : (|Int_set|).(S.SET.t) }.
  Definition with_context context (r : record) :=
    Build context r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_constants constants (r : record) :=
    Build r.(context) constants r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_first_level first_level (r : record) :=
    Build r.(context) r.(constants) first_level r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_level level (r : record) :=
    Build r.(context) r.(constants) r.(first_level) level
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_predecessor_timestamp predecessor_timestamp (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      predecessor_timestamp r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_timestamp timestamp (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) timestamp r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_fitness fitness (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) fitness r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_deposits deposits (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) deposits
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_included_endorsements included_endorsements (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      included_endorsements r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_allowed_endorsements allowed_endorsements (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) allowed_endorsements r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_fees fees (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) fees r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_rewards rewards (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) rewards
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_block_gas block_gas (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      block_gas r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_operation_gas operation_gas (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) operation_gas r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_internal_gas internal_gas (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) internal_gas r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_storage_space_to_pay storage_space_to_pay (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) storage_space_to_pay
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_allocated_contracts allocated_contracts (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      allocated_contracts r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_origination_nonce origination_nonce (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) origination_nonce r.(temporary_big_map)
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_temporary_big_map temporary_big_map (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) temporary_big_map
      r.(internal_nonce) r.(internal_nonces_used).
  Definition with_internal_nonce internal_nonce (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      internal_nonce r.(internal_nonces_used).
  Definition with_internal_nonces_used internal_nonces_used (r : record) :=
    Build r.(context) r.(constants) r.(first_level) r.(level)
      r.(predecessor_timestamp) r.(timestamp) r.(fitness) r.(deposits)
      r.(included_endorsements) r.(allowed_endorsements) r.(fees) r.(rewards)
      r.(block_gas) r.(operation_gas) r.(internal_gas) r.(storage_space_to_pay)
      r.(allocated_contracts) r.(origination_nonce) r.(temporary_big_map)
      r.(internal_nonce) internal_nonces_used.
End t.
Definition t := t.record.

Definition context := t.

Definition root_context := t.

Definition current_level (ctxt : t) : Level_repr.t := t.level ctxt.

Definition predecessor_timestamp (ctxt : t) : Time.t :=
  t.predecessor_timestamp ctxt.

Definition current_timestamp (ctxt : t) : Time.t := t.timestamp ctxt.

Definition current_fitness (ctxt : t) : Int64.t := t.fitness ctxt.

Definition first_level (ctxt : t) : Raw_level_repr.t := t.first_level ctxt.

Definition constants (ctxt : t) : Constants_repr.parametric := t.constants ctxt.

Definition recover (ctxt : t) : Context.t := t.context ctxt.

Definition record_endorsement
  (ctxt : t)
  (k :
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.key))
  : t :=
  match
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.find_opt)
      k (t.allowed_endorsements ctxt) with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some (_, _, true) =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some (d, s, false) =>
    t.with_allowed_endorsements
      ((|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.add)
        k (d, s, true) (t.allowed_endorsements ctxt))
      (t.with_included_endorsements
        (Pervasives.op_plus (t.included_endorsements ctxt) (List.length s)) ctxt)
  end.

Definition init_endorsements
  (ctxt : t)
  (allowed_endorsements :
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.t)
      ((|Signature.Public_key|).(S.SPublic_key.t) * list Z * bool)) : t :=
  if
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.is_empty)
      allowed_endorsements then
    (* ❌ Assert instruction is not handled. *)
    assert false
  else
    if
      (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.is_empty)
        (t.allowed_endorsements ctxt) then
      t.with_allowed_endorsements allowed_endorsements ctxt
    else
      (* ❌ Assert instruction is not handled. *)
      assert false.

Definition allowed_endorsements (ctxt : t)
  : (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.t)
    ((|Signature.Public_key|).(S.SPublic_key.t) * list Z * bool) :=
  t.allowed_endorsements ctxt.

Definition included_endorsements (ctxt : t) : Z := t.included_endorsements ctxt.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition fresh_internal_nonce (ctxt : t) : Error_monad.tzresult (t * Z) :=
  if (|Compare.Int|).(Compare.S.op_gteq) (t.internal_nonce ctxt) 65535 then
    Error_monad.__error_value extensible_type_value
  else
    Error_monad.ok
      ((t.with_internal_nonce (Pervasives.op_plus (t.internal_nonce ctxt) 1)
        ctxt), (t.internal_nonce ctxt)).

Definition reset_internal_nonce (ctxt : t) : t :=
  t.with_internal_nonces_used (|Int_set|).(S.SET.empty)
    (t.with_internal_nonce 0 ctxt).

Definition record_internal_nonce (ctxt : t) (k : (|Int_set|).(S.SET.elt)) : t :=
  t.with_internal_nonces_used
    ((|Int_set|).(S.SET.add) k (t.internal_nonces_used ctxt)) ctxt.

Definition internal_nonce_already_recorded
  (ctxt : t) (k : (|Int_set|).(S.SET.elt)) : bool :=
  (|Int_set|).(S.SET.mem) k (t.internal_nonces_used ctxt).

Definition set_current_fitness (ctxt : t) (fitness : Int64.t) : t :=
  t.with_fitness fitness ctxt.

Definition add_fees (ctxt : t) (fees : Tez_repr.t)
  : Lwt.t (Error_monad.tzresult t) :=
  Error_monad.op_gtgteqquestion
    (Lwt.__return (Tez_repr.op_plusquestion (t.fees ctxt) fees))
    (fun fees => Error_monad.__return (t.with_fees fees ctxt)).

Definition add_rewards (ctxt : t) (rewards : Tez_repr.t)
  : Lwt.t (Error_monad.tzresult t) :=
  Error_monad.op_gtgteqquestion
    (Lwt.__return (Tez_repr.op_plusquestion (t.rewards ctxt) rewards))
    (fun rewards => Error_monad.__return (t.with_rewards rewards ctxt)).

Definition add_deposit
  (ctxt : t)
  (delegate :
    (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.key))
  (deposit : Tez_repr.t) : Lwt.t (Error_monad.tzresult t) :=
  let previous :=
    match
      (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.find_opt)
        delegate (t.deposits ctxt) with
    | Some tz => tz
    | None => Tez_repr.zero
    end in
  Error_monad.op_gtgteqquestion
    (Lwt.__return (Tez_repr.op_plusquestion previous deposit))
    (fun deposit =>
      let deposits :=
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.add)
          delegate deposit (t.deposits ctxt) in
      Error_monad.__return (t.with_deposits deposits ctxt)).

Definition get_deposits (ctxt : t)
  : (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.t)
    Tez_repr.t := t.deposits ctxt.

Definition get_rewards (ctxt : t) : Tez_repr.t := t.rewards ctxt.

Definition get_fees (ctxt : t) : Tez_repr.t := t.fees ctxt.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition init_origination_nonce
  (ctxt : t) (operation_hash : (|Operation_hash|).(S.HASH.t)) : t :=
  let origination_nonce :=
    Some (Contract_repr.initial_origination_nonce operation_hash) in
  t.with_origination_nonce origination_nonce ctxt.

Definition origination_nonce (ctxt : t)
  : Error_monad.tzresult Contract_repr.origination_nonce :=
  match t.origination_nonce ctxt with
  | None => Error_monad.__error_value extensible_type_value
  | Some origination_nonce => Error_monad.ok origination_nonce
  end.

Definition increment_origination_nonce (ctxt : t)
  : Error_monad.tzresult (t * Contract_repr.origination_nonce) :=
  match t.origination_nonce ctxt with
  | None => Error_monad.__error_value extensible_type_value
  | Some cur_origination_nonce =>
    let origination_nonce :=
      Some (Contract_repr.incr_origination_nonce cur_origination_nonce) in
    Error_monad.ok
      ((t.with_origination_nonce origination_nonce ctxt), cur_origination_nonce)
  end.

Definition unset_origination_nonce (ctxt : t) : t :=
  t.with_origination_nonce None ctxt.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition check_gas_limit (ctxt : t) (remaining : (|Compare.Z|).(Compare.S.t))
  : Error_monad.tzresult unit :=
  if
    Pervasives.op_pipepipe
      ((|Compare.Z|).(Compare.S.op_gt) remaining
        (Constants_repr.parametric.hard_gas_limit_per_operation
          (t.constants ctxt)))
      ((|Compare.Z|).(Compare.S.op_lt) remaining Z.zero) then
    Error_monad.__error_value extensible_type_value
  else
    Error_monad.ok tt.

Definition set_gas_limit (ctxt : t) (remaining : Z.t) : t :=
  t.with_internal_gas Gas_limit_repr.internal_gas_zero
    (t.with_operation_gas
      (Gas_limit_repr.Limited
        {| Gas_limit_repr.t.Limited.remaining := remaining |}) ctxt).

Definition set_gas_unlimited (ctxt : t) : t :=
  t.with_operation_gas Gas_limit_repr.Unaccounted ctxt.

Definition consume_gas (ctxt : t) (cost : Gas_limit_repr.cost)
  : Error_monad.tzresult t :=
  Error_monad.op_gtgtquestion
    (Gas_limit_repr.consume (t.block_gas ctxt) (t.operation_gas ctxt)
      (t.internal_gas ctxt) cost)
    (fun function_parameter =>
      let '(block_gas, operation_gas, __internal_gas_value) :=
        function_parameter in
      Error_monad.ok
        (t.with_internal_gas __internal_gas_value
          (t.with_operation_gas operation_gas (t.with_block_gas block_gas ctxt)))).

Definition check_enough_gas (ctxt : t) (cost : Gas_limit_repr.cost)
  : Error_monad.tzresult unit :=
  Gas_limit_repr.check_enough (t.block_gas ctxt) (t.operation_gas ctxt)
    (t.internal_gas ctxt) cost.

Definition gas_level (ctxt : t) : Gas_limit_repr.t := t.operation_gas ctxt.

Definition block_gas_level (ctxt : t) : Z.t := t.block_gas ctxt.

Definition gas_consumed (since : t) (until : t) : Z.t :=
  match ((gas_level since), (gas_level until)) with
  |
    (Gas_limit_repr.Limited {| Gas_limit_repr.t.Limited.remaining := before |},
      Gas_limit_repr.Limited {| Gas_limit_repr.t.Limited.remaining := after |})
    => Z.sub before after
  | (_, _) => Z.zero
  end.

Definition init_storage_space_to_pay (ctxt : t) : t :=
  match t.storage_space_to_pay ctxt with
  | Some _ =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | None =>
    t.with_allocated_contracts (Some 0)
      (t.with_storage_space_to_pay (Some Z.zero) ctxt)
  end.

Definition update_storage_space_to_pay (ctxt : t) (n : Z.t) : t :=
  match t.storage_space_to_pay ctxt with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some storage_space_to_pay =>
    t.with_storage_space_to_pay (Some (Z.add n storage_space_to_pay)) ctxt
  end.

Definition update_allocated_contracts_count (ctxt : t) : t :=
  match t.allocated_contracts ctxt with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some allocated_contracts =>
    t.with_allocated_contracts (Some (Pervasives.succ allocated_contracts)) ctxt
  end.

Definition clear_storage_space_to_pay (ctxt : t) : t * Z.t * Z :=
  match ((t.storage_space_to_pay ctxt), (t.allocated_contracts ctxt)) with
  | (None, _) | (_, None) =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | (Some storage_space_to_pay, Some allocated_contracts) =>
    ((t.with_allocated_contracts None (t.with_storage_space_to_pay None ctxt)),
      storage_space_to_pay, allocated_contracts)
  end.

Inductive missing_key_kind : Set :=
| Del : missing_key_kind
| Copy : missing_key_kind
| Get : missing_key_kind
| __Set : missing_key_kind.

Inductive storage_error : Set :=
| Incompatible_protocol_version : string -> storage_error
| Missing_key : list string -> missing_key_kind -> storage_error
| Existing_key : list string -> storage_error
| Corrupted_data : list string -> storage_error.

Definition storage_error_encoding : Data_encoding.encoding storage_error :=
  Data_encoding.union None
    [
      Data_encoding.__case_value "Incompatible_protocol_version" None
        (Data_encoding.Tag 0)
        (Data_encoding.obj1
          (Data_encoding.req None None "incompatible_protocol_version"
            Data_encoding.__string_value))
        (fun function_parameter =>
          match function_parameter with
          | Incompatible_protocol_version arg => Some arg
          | _ => None
          end) (fun arg => Incompatible_protocol_version arg);
      Data_encoding.__case_value "Missing_key" None (Data_encoding.Tag 1)
        (Data_encoding.obj2
          (Data_encoding.req None None "missing_key"
            (Data_encoding.__list_value None Data_encoding.__string_value))
          (Data_encoding.req None None "function"
            (Data_encoding.string_enum
              [
                ("get",
                  (* ❌ Variants not supported *)
                  (* ❌ `Get *)
                  Get);
                ("set",
                  (* ❌ Variants not supported *)
                  (* ❌ `Set *)
                  __Set);
                ("del",
                  (* ❌ Variants not supported *)
                  (* ❌ `Del *)
                  Del);
                ("copy",
                  (* ❌ Variants not supported *)
                  (* ❌ `Copy *)
                  Copy)
              ])))
        (fun function_parameter =>
          match function_parameter with
          | Missing_key key f => Some (key, f)
          | _ => None
          end)
        (fun function_parameter =>
          let '(key, f) := function_parameter in
          Missing_key key f);
      Data_encoding.__case_value "Existing_key" None (Data_encoding.Tag 2)
        (Data_encoding.obj1
          (Data_encoding.req None None "existing_key"
            (Data_encoding.__list_value None Data_encoding.__string_value)))
        (fun function_parameter =>
          match function_parameter with
          | Existing_key key => Some key
          | _ => None
          end) (fun key => Existing_key key);
      Data_encoding.__case_value "Corrupted_data" None (Data_encoding.Tag 3)
        (Data_encoding.obj1
          (Data_encoding.req None None "corrupted_data"
            (Data_encoding.__list_value None Data_encoding.__string_value)))
        (fun function_parameter =>
          match function_parameter with
          | Corrupted_data key => Some key
          | _ => None
          end) (fun key => Corrupted_data key)
    ].

Definition pp_storage_error
  (ppf : Format.formatter) (function_parameter : storage_error) : unit :=
  match function_parameter with
  | Incompatible_protocol_version version =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Found a context with an unexpected version '"
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "'."
              CamlinternalFormatBasics.End_of_format)))
        "Found a context with an unexpected version '%s'.") version
  | Missing_key key Get =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Missing key '"
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "'."
              CamlinternalFormatBasics.End_of_format))) "Missing key '%s'.")
      (String.concat "/" key)
  | Missing_key key __Set =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Cannot set undefined key '"
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "'."
              CamlinternalFormatBasics.End_of_format)))
        "Cannot set undefined key '%s'.") (String.concat "/" key)
  | Missing_key key Del =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Cannot delete undefined key '"
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "'."
              CamlinternalFormatBasics.End_of_format)))
        "Cannot delete undefined key '%s'.") (String.concat "/" key)
  | Missing_key key Copy =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Cannot copy undefined key '"
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "'."
              CamlinternalFormatBasics.End_of_format)))
        "Cannot copy undefined key '%s'.") (String.concat "/" key)
  | Existing_key key =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Cannot initialize defined key '"
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "'."
              CamlinternalFormatBasics.End_of_format)))
        "Cannot initialize defined key '%s'.") (String.concat "/" key)
  | Corrupted_data key =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Failed to parse the data at '"
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "'."
              CamlinternalFormatBasics.End_of_format)))
        "Failed to parse the data at '%s'.") (String.concat "/" key)
  end.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition __storage_error_value {A : Set} (err : storage_error)
  : Lwt.t (Error_monad.tzresult A) := Error_monad.fail extensible_type_value.

Definition version_key : list string := [ "version" ].

Definition version_value : string := "alpha_current".

Definition version : string := "v1".

Definition first_level_key : list string := [ version; "first_level" ].

Definition constants_key : list string := [ version; "constants" ].

Definition protocol_param_key : list string := [ "protocol_parameters" ].

Definition get_first_level (ctxt : Context.t)
  : Lwt.t (Error_monad.tzresult Raw_level_repr.raw_level) :=
  Error_monad.op_gtgteq (Context.get ctxt first_level_key)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        __storage_error_value
          (Missing_key first_level_key
            (* ❌ Variants not supported *)
            (* ❌ `Get *)
            Get)
      | Some __bytes_value =>
        match
          Data_encoding.Binary.of_bytes Raw_level_repr.encoding __bytes_value
          with
        | None => __storage_error_value (Corrupted_data first_level_key)
        | Some level => Error_monad.__return level
        end
      end).

Definition set_first_level (ctxt : Context.t) (level : Raw_level_repr.raw_level)
  : Lwt.t (Error_monad.tzresult Context.t) :=
  let __bytes_value :=
    Data_encoding.Binary.to_bytes_exn Raw_level_repr.encoding level in
  Error_monad.op_gtgteq (Context.set ctxt first_level_key __bytes_value)
    (fun ctxt => Error_monad.__return ctxt).

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition get_proto_param (ctxt : Context.t)
  : Lwt.t (Error_monad.tzresult (Parameters_repr.t * Context.t)) :=
  Error_monad.op_gtgteq (Context.get ctxt protocol_param_key)
    (fun function_parameter =>
      match function_parameter with
      | None => Pervasives.failwith "Missing protocol parameters."
      | Some __bytes_value =>
        match
          Data_encoding.Binary.of_bytes Data_encoding.__json_value __bytes_value
          with
        | None => Error_monad.fail extensible_type_value
        | Some __json_value =>
          Error_monad.op_gtgteq (Context.del ctxt protocol_param_key)
            (fun ctxt =>
              let 'param :=
                Data_encoding.Json.destruct Parameters_repr.encoding
                  __json_value in
              Error_monad.__return (param, ctxt))
        end
      end).

Definition set_constants
  (ctxt : Context.t) (constants : Constants_repr.parametric)
  : Lwt.t Context.t :=
  let __bytes_value :=
    Data_encoding.Binary.to_bytes_exn Constants_repr.parametric_encoding
      constants in
  Context.set ctxt constants_key __bytes_value.

Definition get_constants (ctxt : Context.t)
  : Lwt.t (Error_monad.tzresult Constants_repr.parametric) :=
  Error_monad.op_gtgteq (Context.get ctxt constants_key)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Pervasives.failwith "Internal error: cannot read constants in context."
      | Some __bytes_value =>
        match
          Data_encoding.Binary.of_bytes Constants_repr.parametric_encoding
            __bytes_value with
        | None =>
          Pervasives.failwith
            "Internal error: cannot parse constants in context."
        | Some constants => Error_monad.__return constants
        end
      end).

Definition patch_constants
  (ctxt : t) (f : Constants_repr.parametric -> Constants_repr.parametric)
  : Lwt.t t :=
  let constants := f (t.constants ctxt) in
  Error_monad.op_gtgteq (set_constants (t.context ctxt) constants)
    (fun context =>
      Lwt.__return (t.with_constants constants (t.with_context context ctxt))).

Definition check_inited (ctxt : Context.t)
  : Lwt.t (Error_monad.tzresult unit) :=
  Error_monad.op_gtgteq (Context.get ctxt version_key)
    (fun function_parameter =>
      match function_parameter with
      | None => Pervasives.failwith "Internal error: un-initialized context."
      | Some __bytes_value =>
        let s := MBytes.to_string __bytes_value in
        if (|Compare.String|).(Compare.S.op_eq) s version_value then
          Error_monad.return_unit
        else
          __storage_error_value (Incompatible_protocol_version s)
      end).

Definition prepare
  (level : int32) (predecessor_timestamp : Time.t) (timestamp : Time.t)
  (fitness : list MBytes.t) (ctxt : Context.t)
  : Lwt.t (Error_monad.tzresult t) :=
  Error_monad.op_gtgteqquestion (Lwt.__return (Raw_level_repr.of_int32 level))
    (fun level =>
      Error_monad.op_gtgteqquestion
        (Lwt.__return (Fitness_repr.to_int64 fitness))
        (fun fitness =>
          Error_monad.op_gtgteqquestion (check_inited ctxt)
            (fun function_parameter =>
              let '_ := function_parameter in
              Error_monad.op_gtgteqquestion (get_constants ctxt)
                (fun constants =>
                  Error_monad.op_gtgteqquestion (get_first_level ctxt)
                    (fun first_level =>
                      let level :=
                        Level_repr.from_raw first_level
                          (Constants_repr.parametric.blocks_per_cycle constants)
                          (Constants_repr.parametric.blocks_per_voting_period
                            constants)
                          (Constants_repr.parametric.blocks_per_commitment
                            constants) level in
                      Error_monad.__return
                        {| t.context := ctxt; t.constants := constants;
                          t.first_level := first_level; t.level := level;
                          t.predecessor_timestamp := predecessor_timestamp;
                          t.timestamp := timestamp; t.fitness := fitness;
                          t.deposits :=
                            (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.empty);
                          t.included_endorsements := 0;
                          t.allowed_endorsements :=
                            (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.empty);
                          t.fees := Tez_repr.zero; t.rewards := Tez_repr.zero;
                          t.block_gas :=
                            Constants_repr.parametric.hard_gas_limit_per_block
                              constants;
                          t.operation_gas := Gas_limit_repr.Unaccounted;
                          t.internal_gas := Gas_limit_repr.internal_gas_zero;
                          t.storage_space_to_pay := None;
                          t.allocated_contracts := None;
                          t.origination_nonce := None;
                          t.temporary_big_map := Z.sub Z.zero Z.one;
                          t.internal_nonce := 0;
                          t.internal_nonces_used := (|Int_set|).(S.SET.empty) |}))))).

Inductive previous_protocol : Set :=
| Genesis : Parameters_repr.t -> previous_protocol
| Alpha_previous : previous_protocol.

Definition check_and_update_protocol_version (ctxt : Context.t)
  : Lwt.t (Error_monad.tzresult (previous_protocol * Context.t)) :=
  Error_monad.op_gtgteqquestion
    (Error_monad.op_gtgteq (Context.get ctxt version_key)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          Pervasives.failwith
            "Internal error: un-initialized context in check_first_block."
        | Some __bytes_value =>
          let s := MBytes.to_string __bytes_value in
          if (|Compare.String|).(Compare.S.op_eq) s version_value then
            Pervasives.failwith
              "Internal error: previously initialized context."
          else
            if (|Compare.String|).(Compare.S.op_eq) s "genesis" then
              Error_monad.op_gtgteqquestion (get_proto_param ctxt)
                (fun function_parameter =>
                  let '(param, ctxt) := function_parameter in
                  Error_monad.__return ((Genesis param), ctxt))
            else
              if (|Compare.String|).(Compare.S.op_eq) s "alpha_previous" then
                Error_monad.__return (Alpha_previous, ctxt)
              else
                __storage_error_value (Incompatible_protocol_version s)
        end))
    (fun function_parameter =>
      let '(previous_proto, ctxt) := function_parameter in
      Error_monad.op_gtgteq
        (Context.set ctxt version_key (MBytes.of_string version_value))
        (fun ctxt => Error_monad.__return (previous_proto, ctxt))).

Definition prepare_first_block
  (level : int32) (timestamp : Time.t) (fitness : list MBytes.t)
  (ctxt : Context.t) : Lwt.t (Error_monad.tzresult (previous_protocol * t)) :=
  Error_monad.op_gtgteqquestion (check_and_update_protocol_version ctxt)
    (fun function_parameter =>
      let '(previous_proto, ctxt) := function_parameter in
      Error_monad.op_gtgteqquestion
        match previous_proto with
        | Genesis param =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Raw_level_repr.of_int32 level))
            (fun first_level =>
              Error_monad.op_gtgteqquestion (set_first_level ctxt first_level)
                (fun ctxt =>
                  Error_monad.op_gtgteq
                    (set_constants ctxt (Parameters_repr.t.constants param))
                    (fun ctxt => Error_monad.__return ctxt)))
        | Alpha_previous => Error_monad.__return ctxt
        end
        (fun ctxt =>
          Error_monad.op_gtgteqquestion
            (prepare level timestamp timestamp fitness ctxt)
            (fun ctxt => Error_monad.__return (previous_proto, ctxt)))).

Definition activate (function_parameter : t)
  : (|Protocol_hash|).(S.HASH.t) -> Lwt.t t :=
  let '{| t.context := c |} as s := function_parameter in
  fun h =>
    Error_monad.op_gtgteq (Updater.activate c h)
      (fun c => Lwt.__return (t.with_context c s)).

Definition fork_test_chain (function_parameter : t)
  : (|Protocol_hash|).(S.HASH.t) -> Time.t -> Lwt.t t :=
  let '{| t.context := c |} as s := function_parameter in
  fun protocol =>
    fun expiration =>
      Error_monad.op_gtgteq (Updater.fork_test_chain c protocol expiration)
        (fun c => Lwt.__return (t.with_context c s)).

Definition key := list string.

Definition value := MBytes.t.

Module T.
  Record signature {t : Set} := {
    t := t;
    context := t;
    mem : context -> key -> Lwt.t bool;
    dir_mem : context -> key -> Lwt.t bool;
    get : context -> key -> Lwt.t (Error_monad.tzresult value);
    get_option : context -> key -> Lwt.t (option value);
    init : context -> key -> value -> Lwt.t (Error_monad.tzresult context);
    set : context -> key -> value -> Lwt.t (Error_monad.tzresult context);
    init_set : context -> key -> value -> Lwt.t context;
    set_option : context -> key -> option value -> Lwt.t context;
    delete : context -> key -> Lwt.t (Error_monad.tzresult context);
    remove : context -> key -> Lwt.t context;
    remove_rec : context -> key -> Lwt.t context;
    copy : context -> key -> key -> Lwt.t (Error_monad.tzresult context);
    fold : forall {a : Set},
      context -> key -> a ->
      ((* `Dir *) key + (* `Key *) key -> a -> Lwt.t a) -> Lwt.t a;
    keys : context -> key -> Lwt.t (list key);
    fold_keys : forall {a : Set},
      context -> key -> a -> (key -> a -> Lwt.t a) -> Lwt.t a;
    project : context -> root_context;
    absolute_key : context -> key -> key;
    consume_gas :
      context -> Gas_limit_repr.cost -> Error_monad.tzresult context;
    check_enough_gas :
      context -> Gas_limit_repr.cost -> Error_monad.tzresult unit;
    description : Storage_description.t context;
  }.
  Arguments signature : clear implicits.
End T.

Definition mem (ctxt : t) (k : Context.key) : Lwt.t bool :=
  Context.mem (t.context ctxt) k.

Definition dir_mem (ctxt : t) (k : Context.key) : Lwt.t bool :=
  Context.dir_mem (t.context ctxt) k.

Definition get (ctxt : t) (k : Context.key)
  : Lwt.t (Error_monad.tzresult Context.value) :=
  Error_monad.op_gtgteq (Context.get (t.context ctxt) k)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        __storage_error_value
          (Missing_key k
            (* ❌ Variants not supported *)
            (* ❌ `Get *)
            Get)
      | Some v => Error_monad.__return v
      end).

Definition get_option (ctxt : t) (k : Context.key)
  : Lwt.t (option Context.value) := Context.get (t.context ctxt) k.

Definition set (ctxt : t) (k : Context.key) (v : Context.value)
  : Lwt.t (Error_monad.tzresult t) :=
  Error_monad.op_gtgteq (Context.mem (t.context ctxt) k)
    (fun function_parameter =>
      match function_parameter with
      | false =>
        __storage_error_value
          (Missing_key k
            (* ❌ Variants not supported *)
            (* ❌ `Set *)
            __Set)
      | true =>
        Error_monad.op_gtgteq (Context.set (t.context ctxt) k v)
          (fun context => Error_monad.__return (t.with_context context ctxt))
      end).

Definition init (ctxt : t) (k : Context.key) (v : Context.value)
  : Lwt.t (Error_monad.tzresult t) :=
  Error_monad.op_gtgteq (Context.mem (t.context ctxt) k)
    (fun function_parameter =>
      match function_parameter with
      | true => __storage_error_value (Existing_key k)
      | false =>
        Error_monad.op_gtgteq (Context.set (t.context ctxt) k v)
          (fun context => Error_monad.__return (t.with_context context ctxt))
      end).

Definition init_set (ctxt : t) (k : Context.key) (v : Context.value)
  : Lwt.t t :=
  Error_monad.op_gtgteq (Context.set (t.context ctxt) k v)
    (fun context => Lwt.__return (t.with_context context ctxt)).

Definition delete (ctxt : t) (k : Context.key)
  : Lwt.t (Error_monad.tzresult t) :=
  Error_monad.op_gtgteq (Context.mem (t.context ctxt) k)
    (fun function_parameter =>
      match function_parameter with
      | false =>
        __storage_error_value
          (Missing_key k
            (* ❌ Variants not supported *)
            (* ❌ `Del *)
            Del)
      | true =>
        Error_monad.op_gtgteq (Context.del (t.context ctxt) k)
          (fun context => Error_monad.__return (t.with_context context ctxt))
      end).

Definition remove (ctxt : t) (k : Context.key) : Lwt.t t :=
  Error_monad.op_gtgteq (Context.del (t.context ctxt) k)
    (fun context => Lwt.__return (t.with_context context ctxt)).

Definition set_option
  (ctxt : t) (k : Context.key) (function_parameter : option Context.value)
  : Lwt.t t :=
  match function_parameter with
  | None => remove ctxt k
  | Some v => init_set ctxt k v
  end.

Definition remove_rec (ctxt : t) (k : Context.key) : Lwt.t t :=
  Error_monad.op_gtgteq (Context.remove_rec (t.context ctxt) k)
    (fun context => Lwt.__return (t.with_context context ctxt)).

Definition copy (ctxt : t) (from : Context.key) (to_ : Context.key)
  : Lwt.t (Error_monad.tzresult t) :=
  Error_monad.op_gtgteq (Context.copy (t.context ctxt) from to_)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        __storage_error_value
          (Missing_key from
            (* ❌ Variants not supported *)
            (* ❌ `Copy *)
            Copy)
      | Some context => Error_monad.__return (t.with_context context ctxt)
      end).

Definition fold {A : Set}
  (ctxt : t) (k : Context.key) (init : A)
  (f : (* `Dir *) Context.key + (* `Key *) Context.key -> A -> Lwt.t A)
  : Lwt.t A := Context.fold (t.context ctxt) k init f.

Definition keys (ctxt : t) (k : Context.key) : Lwt.t (list Context.key) :=
  Context.keys (t.context ctxt) k.

Definition fold_keys {A : Set}
  (ctxt : t) (k : Context.key) (init : A) (f : Context.key -> A -> Lwt.t A)
  : Lwt.t A := Context.fold_keys (t.context ctxt) k init f.

Definition project {A : Set} (x : A) : A := x.

Definition absolute_key {A B : Set} (function_parameter : A) : B -> B :=
  let '_ := function_parameter in
  fun k => k.

Definition description {A : Set} : Storage_description.t A := axiom.

Definition fresh_temporary_big_map (ctxt : t) : t * Z.t :=
  ((t.with_temporary_big_map (Z.sub (t.temporary_big_map ctxt) Z.one) ctxt),
    (t.temporary_big_map ctxt)).

Definition reset_temporary_big_map (ctxt : t) : t :=
  t.with_temporary_big_map (Z.sub Z.zero Z.one) ctxt.

Definition temporary_big_maps {A : Set}
  (ctxt : t) (f : A -> Z.t -> Lwt.t A) (acc : A) : Lwt.t A :=
  let fix iter (acc : A) (id : Z.t) {struct acc} : Lwt.t A :=
    if Z.equal id (t.temporary_big_map ctxt) then
      Lwt.__return acc
    else
      Error_monad.op_gtgteq (f acc id) (fun acc => iter acc (Z.sub id Z.one)) in
  iter acc (Z.sub Z.zero Z.one).

Raw_context_mli

  • OCaml size: 293 lines
  • Coq size: 248 lines (-16% compared to OCaml)
raw_context.mli 8 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** {1 Errors} *)

type error += Too_many_internal_operations (* `Permanent *)

type missing_key_kind = [`Get | `Set | `Del | `Copy]

(** An internal storage error that should not happen *)
type storage_error =
  | Incompatible_protocol_version of string
  | Missing_key of string list * missing_key_kind
  | Existing_key of string list
  | Corrupted_data of string list

type error += Storage_error of storage_error

type error += Failed_to_parse_parameter of MBytes.t

type error += Failed_to_decode_parameter of Data_encoding.json * string

val storage_error : storage_error -> 'a tzresult Lwt.t

(** {1 Abstract Context} *)

(** Abstract view of the context.
    Includes a handle to the functional key-value database
    ({!Context.t}) along with some in-memory values (gas, etc.). *)
type t

type context = t

type root_context = t

(** Retrieves the state of the database and gives its abstract view.
    It also returns wether this is the first block validated
    with this version of the protocol. *)
val prepare :
  level:Int32.t ->
  predecessor_timestamp:Time.t ->
  timestamp:Time.t ->
  fitness:Fitness.t ->
  Context.t ->
  context tzresult Lwt.t

type previous_protocol = Genesis of Parameters_repr.t | Alpha_previous

val prepare_first_block :
  level:int32 ->
  timestamp:Time.t ->
  fitness:Fitness.t ->
  Context.t ->
  (previous_protocol * context) tzresult Lwt.t

val activate : context -> Protocol_hash.t -> t Lwt.t

val fork_test_chain : context -> Protocol_hash.t -> Time.t -> t Lwt.t

(** Returns the state of the database resulting of operations on its
    abstract view *)
val recover : context -> Context.t

val current_level : context -> Level_repr.t

val predecessor_timestamp : context -> Time.t

val current_timestamp : context -> Time.t

val current_fitness : context -> Int64.t

val set_current_fitness : context -> Int64.t -> t

val constants : context -> Constants_repr.parametric

val patch_constants :
  context ->
  (Constants_repr.parametric -> Constants_repr.parametric) ->
  context Lwt.t

val first_level : context -> Raw_level_repr.t

(** Increment the current block fee stash that will be credited to baker's
    frozen_fees account at finalize_application *)
val add_fees : context -> Tez_repr.t -> context tzresult Lwt.t

(** Increment the current block reward stash that will be credited to baker's
    frozen_fees account at finalize_application *)
val add_rewards : context -> Tez_repr.t -> context tzresult Lwt.t

(** Increment the current block deposit stash for a specific delegate. All the
    delegates' frozen_deposit accounts are credited at finalize_application *)
val add_deposit :
  context ->
  Signature.Public_key_hash.t ->
  Tez_repr.t ->
  context tzresult Lwt.t

val get_fees : context -> Tez_repr.t

val get_rewards : context -> Tez_repr.t

val get_deposits : context -> Tez_repr.t Signature.Public_key_hash.Map.t

type error += Gas_limit_too_high (* `Permanent *)

val check_gas_limit : t -> Z.t -> unit tzresult

val set_gas_limit : t -> Z.t -> t

val set_gas_unlimited : t -> t

val gas_level : t -> Gas_limit_repr.t

val gas_consumed : since:t -> until:t -> Z.t

val block_gas_level : t -> Z.t

val init_storage_space_to_pay : t -> t

val update_storage_space_to_pay : t -> Z.t -> t

val update_allocated_contracts_count : t -> t

val clear_storage_space_to_pay : t -> t * Z.t * int

type error += Undefined_operation_nonce (* `Permanent *)

val init_origination_nonce : t -> Operation_hash.t -> t

val origination_nonce : t -> Contract_repr.origination_nonce tzresult

val increment_origination_nonce :
  t -> (t * Contract_repr.origination_nonce) tzresult

val unset_origination_nonce : t -> t

(** {1 Generic accessors} *)

type key = string list

type value = MBytes.t

(** All context manipulation functions. This signature is included
    as-is for direct context accesses, and used in {!Storage_functors}
    to provide restricted views to the context. *)
module type T = sig
  type t

  type context = t

  (** Tells if the key is already defined as a value. *)
  val mem : context -> key -> bool Lwt.t

  (** Tells if the key is already defined as a directory. *)
  val dir_mem : context -> key -> bool Lwt.t

  (** Retrieve the value from the storage bucket ; returns a
      {!Storage_error Missing_key} if the key is not set. *)
  val get : context -> key -> value tzresult Lwt.t

  (** Retrieves the value from the storage bucket ; returns [None] if
      the data is not initialized. *)
  val get_option : context -> key -> value option Lwt.t

  (** Allocates the storage bucket and initializes it ; returns a
      {!Storage_error Existing_key} if the bucket exists. *)
  val init : context -> key -> value -> context tzresult Lwt.t

  (** Updates the content of the bucket ; returns a {!Storage_error
      Missing_key} if the value does not exists. *)
  val set : context -> key -> value -> context tzresult Lwt.t

  (** Allocates the data and initializes it with a value ; just
      updates it if the bucket exists. *)
  val init_set : context -> key -> value -> context Lwt.t

  (** When the value is [Some v], allocates the data and initializes
      it with [v] ; just updates it if the bucket exists. When the
      valus is [None], delete the storage bucket when the value ; does
      nothing if the bucket does not exists. *)
  val set_option : context -> key -> value option -> context Lwt.t

  (** Delete the storage bucket ; returns a {!Storage_error
      Missing_key} if the bucket does not exists. *)
  val delete : context -> key -> context tzresult Lwt.t

  (** Removes the storage bucket and its contents ; does nothing if the
      bucket does not exists. *)
  val remove : context -> key -> context Lwt.t

  (** Recursively removes all the storage buckets and contents ; does
      nothing if no bucket exists. *)
  val remove_rec : context -> key -> context Lwt.t

  val copy : context -> from:key -> to_:key -> context tzresult Lwt.t

  (** Iterator on all the items of a given directory. *)
  val fold :
    context ->
    key ->
    init:'a ->
    f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) ->
    'a Lwt.t

  (** Recursively list all subkeys of a given key. *)
  val keys : context -> key -> key list Lwt.t

  (** Recursive iterator on all the subkeys of a given key. *)
  val fold_keys :
    context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  (** Internally used in {!Storage_functors} to escape from a view. *)
  val project : context -> root_context

  (** Internally used in {!Storage_functors} to retrieve a full key
      from partial key relative a view. *)
  val absolute_key : context -> key -> key

  (** Internally used in {!Storage_functors} to consume gas from
      within a view. *)
  val consume_gas : context -> Gas_limit_repr.cost -> context tzresult

  (** Check if consume_gas will fail *)
  val check_enough_gas : context -> Gas_limit_repr.cost -> unit tzresult

  val description : context Storage_description.t
end

include T with type t := t and type context := context

(** Initialize the local nonce used for preventing a script to
    duplicate an internal operation to replay it. *)
val reset_internal_nonce : context -> context

(** Increments the internal operation nonce. *)
val fresh_internal_nonce : context -> (context * int) tzresult

(** Mark an internal operation nonce as taken. *)
val record_internal_nonce : context -> int -> context

(** Check is the internal operation nonce has been taken. *)
val internal_nonce_already_recorded : context -> int -> bool

(** Returns a map where to each endorser's pkh is associated the list of its
    endorsing slots (in decreasing order) for a given level. *)
val allowed_endorsements :
  context ->
  (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t

(** Keep track of the number of endorsements that are included in a block *)
val included_endorsements : context -> int

(** Initializes the map of allowed endorsements, this function must only be
    called once. *)
val init_endorsements :
  context ->
  (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ->
  context

(** Marks an endorsment in the map as used. *)
val record_endorsement : context -> Signature.Public_key_hash.t -> context

(** Provide a fresh identifier for a temporary big map (negative index). *)
val fresh_temporary_big_map : context -> context * Z.t

(** Reset the temporary big_map identifier generator to [-1]. *)
val reset_temporary_big_map : context -> context

(** Iterate over all created temporary big maps since the last {!reset_temporary_big_map}. *)
val temporary_big_maps : context -> ('a -> Z.t -> 'a Lwt.t) -> 'a -> 'a Lwt.t
Raw_context_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Constants_repr.
Require Tezos.Contract_repr.
Require Tezos.Gas_limit_repr.
Require Tezos.Level_repr.
Require Tezos.Parameters_repr.
Require Tezos.Raw_level_repr.
Require Tezos.Storage_description.
Require Tezos.Tez_repr.

(* extensible_type error *)

Inductive missing_key_kind : Set :=
| Del : missing_key_kind
| Copy : missing_key_kind
| Get : missing_key_kind
| __Set : missing_key_kind.

Inductive storage_error : Set :=
| Incompatible_protocol_version : string -> storage_error
| Missing_key : list string -> missing_key_kind -> storage_error
| Existing_key : list string -> storage_error
| Corrupted_data : list string -> storage_error.

(* extensible_type error *)

(* extensible_type error *)

(* extensible_type error *)

Parameter __storage_error_value : forall {a : Set},
  storage_error -> Lwt.t (Error_monad.tzresult a).

Parameter t : Set.

Definition context := t.

Definition root_context := t.

Parameter prepare :
  Int32.t -> Time.t -> Time.t -> (|Fitness|).(S.T.t) -> Context.t ->
  Lwt.t (Error_monad.tzresult context).

Inductive previous_protocol : Set :=
| Genesis : Parameters_repr.t -> previous_protocol
| Alpha_previous : previous_protocol.

Parameter prepare_first_block :
  int32 -> Time.t -> (|Fitness|).(S.T.t) -> Context.t ->
  Lwt.t (Error_monad.tzresult (previous_protocol * context)).

Parameter activate : context -> (|Protocol_hash|).(S.HASH.t) -> Lwt.t t.

Parameter fork_test_chain :
  context -> (|Protocol_hash|).(S.HASH.t) -> Time.t -> Lwt.t t.

Parameter recover : context -> Context.t.

Parameter current_level : context -> Level_repr.t.

Parameter predecessor_timestamp : context -> Time.t.

Parameter current_timestamp : context -> Time.t.

Parameter current_fitness : context -> Int64.t.

Parameter set_current_fitness : context -> Int64.t -> t.

Parameter constants : context -> Constants_repr.parametric.

Parameter patch_constants :
  context -> (Constants_repr.parametric -> Constants_repr.parametric) ->
  Lwt.t context.

Parameter first_level : context -> Raw_level_repr.t.

Parameter add_fees :
  context -> Tez_repr.t -> Lwt.t (Error_monad.tzresult context).

Parameter add_rewards :
  context -> Tez_repr.t -> Lwt.t (Error_monad.tzresult context).

Parameter add_deposit :
  context -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Tez_repr.t -> Lwt.t (Error_monad.tzresult context).

Parameter get_fees : context -> Tez_repr.t.

Parameter get_rewards : context -> Tez_repr.t.

Parameter get_deposits :
  context ->
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.t)
    Tez_repr.t.

(* extensible_type error *)

Parameter check_gas_limit : t -> Z.t -> Error_monad.tzresult unit.

Parameter set_gas_limit : t -> Z.t -> t.

Parameter set_gas_unlimited : t -> t.

Parameter gas_level : t -> Gas_limit_repr.t.

Parameter gas_consumed : t -> t -> Z.t.

Parameter block_gas_level : t -> Z.t.

Parameter init_storage_space_to_pay : t -> t.

Parameter update_storage_space_to_pay : t -> Z.t -> t.

Parameter update_allocated_contracts_count : t -> t.

Parameter clear_storage_space_to_pay : t -> t * Z.t * Z.

(* extensible_type error *)

Parameter init_origination_nonce : t -> (|Operation_hash|).(S.HASH.t) -> t.

Parameter origination_nonce :
  t -> Error_monad.tzresult Contract_repr.origination_nonce.

Parameter increment_origination_nonce :
  t -> Error_monad.tzresult (t * Contract_repr.origination_nonce).

Parameter unset_origination_nonce : t -> t.

Definition key := list string.

Definition value := MBytes.t.

Module T.
  Record signature {t : Set} := {
    t := t;
    context := t;
    mem : context -> key -> Lwt.t bool;
    dir_mem : context -> key -> Lwt.t bool;
    get : context -> key -> Lwt.t (Error_monad.tzresult value);
    get_option : context -> key -> Lwt.t (option value);
    init : context -> key -> value -> Lwt.t (Error_monad.tzresult context);
    set : context -> key -> value -> Lwt.t (Error_monad.tzresult context);
    init_set : context -> key -> value -> Lwt.t context;
    set_option : context -> key -> option value -> Lwt.t context;
    delete : context -> key -> Lwt.t (Error_monad.tzresult context);
    remove : context -> key -> Lwt.t context;
    remove_rec : context -> key -> Lwt.t context;
    copy : context -> key -> key -> Lwt.t (Error_monad.tzresult context);
    fold : forall {a : Set},
      context -> key -> a ->
      ((* `Dir *) key + (* `Key *) key -> a -> Lwt.t a) -> Lwt.t a;
    keys : context -> key -> Lwt.t (list key);
    fold_keys : forall {a : Set},
      context -> key -> a -> (key -> a -> Lwt.t a) -> Lwt.t a;
    project : context -> root_context;
    absolute_key : context -> key -> key;
    consume_gas :
      context -> Gas_limit_repr.cost -> Error_monad.tzresult context;
    check_enough_gas :
      context -> Gas_limit_repr.cost -> Error_monad.tzresult unit;
    description : Storage_description.t context;
  }.
  Arguments signature : clear implicits.
End T.

Parameter Included_T : {_ : unit & T.signature t}.

Definition mem := (|Included_T|).(T.mem).

Definition dir_mem := (|Included_T|).(T.dir_mem).

Definition get := (|Included_T|).(T.get).

Definition get_option := (|Included_T|).(T.get_option).

Definition init := (|Included_T|).(T.init).

Definition set := (|Included_T|).(T.set).

Definition init_set := (|Included_T|).(T.init_set).

Definition set_option := (|Included_T|).(T.set_option).

Definition delete := (|Included_T|).(T.delete).

Definition remove := (|Included_T|).(T.remove).

Definition remove_rec := (|Included_T|).(T.remove_rec).

Definition copy := (|Included_T|).(T.copy).

Definition fold := (|Included_T|).(T.fold).

Definition keys := (|Included_T|).(T.keys).

Definition fold_keys := (|Included_T|).(T.fold_keys).

Definition project := (|Included_T|).(T.project).

Definition absolute_key := (|Included_T|).(T.absolute_key).

Definition consume_gas := (|Included_T|).(T.consume_gas).

Definition check_enough_gas := (|Included_T|).(T.check_enough_gas).

Definition description := (|Included_T|).(T.description).

Parameter reset_internal_nonce : context -> context.

Parameter fresh_internal_nonce : context -> Error_monad.tzresult (context * Z).

Parameter record_internal_nonce : context -> Z -> context.

Parameter internal_nonce_already_recorded : context -> Z -> bool.

Parameter allowed_endorsements :
  context ->
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.t)
    ((|Signature.Public_key|).(S.SPublic_key.t) * list Z * bool).

Parameter included_endorsements : context -> Z.

Parameter init_endorsements :
  context ->
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.Map).(S.INDEXES_Map.t)
    ((|Signature.Public_key|).(S.SPublic_key.t) * list Z * bool) -> context.

Parameter record_endorsement :
  context -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) -> context.

Parameter fresh_temporary_big_map : context -> context * Z.t.

Parameter reset_temporary_big_map : context -> context.

Parameter temporary_big_maps : forall {a : Set},
  context -> (a -> Z.t -> Lwt.t a) -> a -> Lwt.t a.

Raw_level_repr

  • OCaml size: 102 lines
  • Coq size: 118 lines (+15% compared to OCaml)
raw_level_repr.ml 5 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = int32

type raw_level = t

include (Compare.Int32 : Compare.S with type t := t)

let encoding = Data_encoding.int32

let pp ppf level = Format.fprintf ppf "%ld" level

let rpc_arg =
  let construct raw_level = Int32.to_string raw_level in
  let destruct str =
    match Int32.of_string str with
    | exception _ ->
        Error "Cannot parse level"
    | raw_level ->
        Ok raw_level
  in
  RPC_arg.make
    ~descr:"A level integer"
    ~name:"block_level"
    ~construct
    ~destruct
    ()

let root = 0l

let succ = Int32.succ

let pred l = if l = 0l then None else Some (Int32.pred l)

let diff = Int32.sub

let to_int32 l = l

let of_int32_exn l =
  if Compare.Int32.(l >= 0l) then l else invalid_arg "Level_repr.of_int32"

type error += Unexpected_level of Int32.t (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"unexpected_level"
    ~title:"Unexpected level"
    ~description:"Level must be non-negative."
    ~pp:(fun ppf l ->
      Format.fprintf
        ppf
        "The level is %s but should be non-negative."
        (Int32.to_string l))
    Data_encoding.(obj1 (req "level" int32))
    (function Unexpected_level l -> Some l | _ -> None)
    (fun l -> Unexpected_level l)

let of_int32 l = try Ok (of_int32_exn l) with _ -> error (Unexpected_level l)

module Index = struct
  type t = raw_level

  let path_length = 1

  let to_path level l = Int32.to_string level :: l

  let of_path = function
    | [s] -> (
      try Some (Int32.of_string s) with _ -> None )
    | _ ->
        None

  let rpc_arg = rpc_arg

  let encoding = encoding

  let compare = compare
end
Raw_level_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Definition t := int32.

Definition raw_level := t.

Definition op_eq := (|Compare.Int32|).(Compare.S.op_eq).

Definition op_ltgt := (|Compare.Int32|).(Compare.S.op_ltgt).

Definition op_lt := (|Compare.Int32|).(Compare.S.op_lt).

Definition op_lteq := (|Compare.Int32|).(Compare.S.op_lteq).

Definition op_gteq := (|Compare.Int32|).(Compare.S.op_gteq).

Definition op_gt := (|Compare.Int32|).(Compare.S.op_gt).

Definition compare := (|Compare.Int32|).(Compare.S.compare).

Definition equal := (|Compare.Int32|).(Compare.S.equal).

Definition max := (|Compare.Int32|).(Compare.S.max).

Definition min := (|Compare.Int32|).(Compare.S.min).

Definition encoding : Data_encoding.encoding int32 :=
  Data_encoding.__int32_value.

Definition pp (ppf : Format.formatter) (level : int32) : unit :=
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
        CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.No_precision
        CamlinternalFormatBasics.End_of_format) "%ld") level.

Definition rpc_arg : RPC_arg.arg int32 :=
  let construct (raw_level : int32) : string :=
    Int32.to_string raw_level in
  let destruct (str : string) : Pervasives.result int32 string :=
    let 'raw_level := Int32.of_string str in
    Pervasives.Ok raw_level in
  RPC_arg.make (Some "A level integer") "block_level" destruct construct tt.

Definition root : int32 :=
  (* ❌ Constant of type int32 is converted to int *)
  0.

Definition succ : int32 -> int32 := Int32.succ.

Definition pred (l : t) : option int32 :=
  if
    op_eq l
      (* ❌ Constant of type int32 is converted to int *)
      0 then
    None
  else
    Some (Int32.pred l).

Definition diff : int32 -> int32 -> int32 := Int32.sub.

Definition to_int32 {A : Set} (l : A) : A := l.

Definition of_int32_exn (l : (|Compare.Int32|).(Compare.S.t))
  : (|Compare.Int32|).(Compare.S.t) :=
  if
    (|Compare.Int32|).(Compare.S.op_gteq) l
      (* ❌ Constant of type int32 is converted to int *)
      0 then
    l
  else
    Pervasives.invalid_arg "Level_repr.of_int32".

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition of_int32 (l : (|Compare.Int32|).(Compare.S.t))
  : Pervasives.result (|Compare.Int32|).(Compare.S.t) (list Error_monad.__error) :=
  (* ❌ Try-with are not handled *)
  try (Pervasives.Ok (of_int32_exn l)).

Module Index.
  Definition t := raw_level.
  
  Definition path_length : Z := 1.
  
  Definition to_path (level : int32) (l : list string) : list string :=
    cons (Int32.to_string level) l.
  
  Definition of_path (function_parameter : list string) : option int32 :=
    match function_parameter with
    | cons s [] =>
      (* ❌ Try-with are not handled *)
      try (Some (Int32.of_string s))
    | _ => None
    end.
  
  Definition rpc_arg : RPC_arg.arg int32 := rpc_arg.
  
  Definition encoding : Data_encoding.encoding int32 := encoding.
  
  Definition compare : t -> t -> Z := compare.
End Index.

Raw_level_repr_mli

  • OCaml size: 55 lines
  • Coq size: 61 lines (+10% compared to OCaml)
raw_level_repr.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** The shell's notion of a level: an integer indicating the number of blocks
    since genesis: genesis is 0, all other blocks have increasing levels from
    there. *)
type t

type raw_level = t

val encoding : raw_level Data_encoding.t

val rpc_arg : raw_level RPC_arg.arg

val pp : Format.formatter -> raw_level -> unit

include Compare.S with type t := raw_level

val to_int32 : raw_level -> int32

val of_int32_exn : int32 -> raw_level

val of_int32 : int32 -> raw_level tzresult

val diff : raw_level -> raw_level -> int32

val root : raw_level

val succ : raw_level -> raw_level

val pred : raw_level -> raw_level option

module Index : Storage_description.INDEX with type t = raw_level
Raw_level_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Storage_description.

Parameter t : Set.

Definition raw_level := t.

Parameter encoding : Data_encoding.t raw_level.

Parameter rpc_arg : RPC_arg.arg raw_level.

Parameter pp : Format.formatter -> raw_level -> unit.

Parameter Included_S : {_ : unit & Compare.S.signature raw_level}.

Definition op_eq := (|Included_S|).(Compare.S.op_eq).

Definition op_ltgt := (|Included_S|).(Compare.S.op_ltgt).

Definition op_lt := (|Included_S|).(Compare.S.op_lt).

Definition op_lteq := (|Included_S|).(Compare.S.op_lteq).

Definition op_gteq := (|Included_S|).(Compare.S.op_gteq).

Definition op_gt := (|Included_S|).(Compare.S.op_gt).

Definition compare := (|Included_S|).(Compare.S.compare).

Definition equal := (|Included_S|).(Compare.S.equal).

Definition max := (|Included_S|).(Compare.S.max).

Definition min := (|Included_S|).(Compare.S.min).

Parameter to_int32 : raw_level -> int32.

Parameter of_int32_exn : int32 -> raw_level.

Parameter of_int32 : int32 -> Error_monad.tzresult raw_level.

Parameter diff : raw_level -> raw_level -> int32.

Parameter root : raw_level.

Parameter succ : raw_level -> raw_level.

Parameter pred : raw_level -> option raw_level.

Parameter Index : {_ : unit & Storage_description.INDEX.signature raw_level}.

Roll_repr

  • OCaml size: 65 lines
  • Coq size: 82 lines (+26% compared to OCaml)
roll_repr.ml 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Compare.Int32

type roll = t

let encoding = Data_encoding.int32

let first = 0l

let succ i = Int32.succ i

let random sequence ~bound = Seed_repr.take_int32 sequence bound

let rpc_arg = RPC_arg.like RPC_arg.int32 "roll"

let to_int32 v = v

module Index = struct
  type t = roll

  let path_length = 3

  let to_path roll l =
    (Int32.to_string @@ Int32.logand roll (Int32.of_int 0xff))
    :: ( Int32.to_string
       @@ Int32.logand (Int32.shift_right_logical roll 8) (Int32.of_int 0xff)
       )
    :: Int32.to_string roll :: l

  let of_path = function
    | _ :: _ :: s :: _ -> (
      try Some (Int32.of_string s) with _ -> None )
    | _ ->
        None

  let rpc_arg = rpc_arg

  let encoding = encoding

  let compare = compare
end
Roll_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Seed_repr.

Definition t := (|Compare.Int32|).(Compare.S.t).

Definition op_eq := (|Compare.Int32|).(Compare.S.op_eq).

Definition op_ltgt := (|Compare.Int32|).(Compare.S.op_ltgt).

Definition op_lt := (|Compare.Int32|).(Compare.S.op_lt).

Definition op_lteq := (|Compare.Int32|).(Compare.S.op_lteq).

Definition op_gteq := (|Compare.Int32|).(Compare.S.op_gteq).

Definition op_gt := (|Compare.Int32|).(Compare.S.op_gt).

Definition compare := (|Compare.Int32|).(Compare.S.compare).

Definition equal := (|Compare.Int32|).(Compare.S.equal).

Definition max := (|Compare.Int32|).(Compare.S.max).

Definition min := (|Compare.Int32|).(Compare.S.min).

Definition roll := t.

Definition encoding : Data_encoding.encoding int32 :=
  Data_encoding.__int32_value.

Definition first : int32 :=
  (* ❌ Constant of type int32 is converted to int *)
  0.

Definition succ (i : int32) : int32 := Int32.succ i.

Definition random (__sequence_value : Seed_repr.sequence) (bound : int32)
  : int32 * Seed_repr.sequence := Seed_repr.take_int32 __sequence_value bound.

Definition rpc_arg : RPC_arg.arg int32 :=
  RPC_arg.like RPC_arg.__int32_value None "roll".

Definition to_int32 {A : Set} (v : A) : A := v.

Module Index.
  Definition t := roll.
  
  Definition path_length : Z := 3.
  
  Definition to_path (roll : int32) (l : list string) : list string :=
    cons
      (Pervasives.op_atat Int32.to_string (Int32.logand roll (Int32.of_int 255)))
      (cons
        (Pervasives.op_atat Int32.to_string
          (Int32.logand (Int32.shift_right_logical roll 8) (Int32.of_int 255)))
        (cons (Int32.to_string roll) l)).
  
  Definition of_path (function_parameter : list string) : option int32 :=
    match function_parameter with
    | cons _ (cons _ (cons s _)) =>
      (* ❌ Try-with are not handled *)
      try (Some (Int32.of_string s))
    | _ => None
    end.
  
  Definition rpc_arg : RPC_arg.arg int32 := rpc_arg.
  
  Definition encoding : Data_encoding.encoding int32 := encoding.
  
  Definition compare : t -> t -> Z := compare.
End Index.

Roll_repr_mli

  • OCaml size: 44 lines
  • Coq size: 34 lines (-23% compared to OCaml)
roll_repr.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = private int32

type roll = t

val encoding : roll Data_encoding.t

val rpc_arg : roll RPC_arg.t

val random : Seed_repr.sequence -> bound:roll -> roll * Seed_repr.sequence

val first : roll

val succ : roll -> roll

val to_int32 : roll -> Int32.t

val ( = ) : roll -> roll -> bool

module Index : Storage_description.INDEX with type t = roll
Roll_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Seed_repr.
Require Tezos.Storage_description.

Definition t := int32.

Definition roll := t.

Parameter encoding : Data_encoding.t roll.

Parameter rpc_arg : RPC_arg.t roll.

Parameter random : Seed_repr.sequence -> roll -> roll * Seed_repr.sequence.

Parameter first : roll.

Parameter succ : roll -> roll.

Parameter to_int32 : roll -> Int32.t.

Parameter op_eq : roll -> roll -> bool.

Parameter Index : {_ : unit & Storage_description.INDEX.signature roll}.

Roll_storage

  • OCaml size: 604 lines
  • Coq size: 787 lines (+30% compared to OCaml)
roll_storage.ml 7 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Misc

type error +=
  | Consume_roll_change (* `Permanent *)
  | No_roll_for_delegate (* `Permanent *)
  | No_roll_snapshot_for_cycle of Cycle_repr.t (* `Permanent *)
  | Unregistered_delegate of Signature.Public_key_hash.t

(* `Permanent *)

let () =
  let open Data_encoding in
  (* Consume roll change *)
  register_error_kind
    `Permanent
    ~id:"contract.manager.consume_roll_change"
    ~title:"Consume roll change"
    ~description:"Change is not enough to consume a roll."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Not enough change to consume a roll.")
    empty
    (function Consume_roll_change -> Some () | _ -> None)
    (fun () -> Consume_roll_change) ;
  (* No roll for delegate *)
  register_error_kind
    `Permanent
    ~id:"contract.manager.no_roll_for_delegate"
    ~title:"No roll for delegate"
    ~description:"Delegate has no roll."
    ~pp:(fun ppf () -> Format.fprintf ppf "Delegate has no roll.")
    empty
    (function No_roll_for_delegate -> Some () | _ -> None)
    (fun () -> No_roll_for_delegate) ;
  (* No roll snapshot for cycle *)
  register_error_kind
    `Permanent
    ~id:"contract.manager.no_roll_snapshot_for_cycle"
    ~title:"No roll snapshot for cycle"
    ~description:
      "A snapshot of the rolls distribution does not exist for this cycle."
    ~pp:(fun ppf c ->
      Format.fprintf
        ppf
        "A snapshot of the rolls distribution does not exist for cycle %a"
        Cycle_repr.pp
        c)
    (obj1 (req "cycle" Cycle_repr.encoding))
    (function No_roll_snapshot_for_cycle c -> Some c | _ -> None)
    (fun c -> No_roll_snapshot_for_cycle c) ;
  (* Unregistered delegate *)
  register_error_kind
    `Permanent
    ~id:"contract.manager.unregistered_delegate"
    ~title:"Unregistered delegate"
    ~description:"A contract cannot be delegated to an unregistered delegate"
    ~pp:(fun ppf k ->
      Format.fprintf
        ppf
        "The provided public key (with hash %a) is  not registered as valid \
         delegate key."
        Signature.Public_key_hash.pp
        k)
    (obj1 (req "hash" Signature.Public_key_hash.encoding))
    (function Unregistered_delegate k -> Some k | _ -> None)
    (fun k -> Unregistered_delegate k)

let get_contract_delegate c contract =
  Storage.Contract.Delegate.get_option c contract

let delegate_pubkey ctxt delegate =
  Storage.Contract.Manager.get_option
    ctxt
    (Contract_repr.implicit_contract delegate)
  >>=? function
  | None | Some (Manager_repr.Hash _) ->
      fail (Unregistered_delegate delegate)
  | Some (Manager_repr.Public_key pk) ->
      return pk

let clear_cycle c cycle =
  Storage.Roll.Snapshot_for_cycle.get c cycle
  >>=? fun index ->
  Storage.Roll.Snapshot_for_cycle.delete c cycle
  >>=? fun c ->
  Storage.Roll.Last_for_snapshot.delete (c, cycle) index
  >>=? fun c ->
  Storage.Roll.Owner.delete_snapshot c (cycle, index) >>= fun c -> return c

let fold ctxt ~f init =
  Storage.Roll.Next.get ctxt
  >>=? fun last ->
  let rec loop ctxt roll acc =
    acc
    >>=? fun acc ->
    if Roll_repr.(roll = last) then return acc
    else
      Storage.Roll.Owner.get_option ctxt roll
      >>=? function
      | None ->
          loop ctxt (Roll_repr.succ roll) (return acc)
      | Some delegate ->
          loop ctxt (Roll_repr.succ roll) (f roll delegate acc)
  in
  loop ctxt Roll_repr.first (return init)

let snapshot_rolls_for_cycle ctxt cycle =
  Storage.Roll.Snapshot_for_cycle.get ctxt cycle
  >>=? fun index ->
  Storage.Roll.Snapshot_for_cycle.set ctxt cycle (index + 1)
  >>=? fun ctxt ->
  Storage.Roll.Owner.snapshot ctxt (cycle, index)
  >>=? fun ctxt ->
  Storage.Roll.Next.get ctxt
  >>=? fun last ->
  Storage.Roll.Last_for_snapshot.init (ctxt, cycle) index last
  >>=? fun ctxt -> return ctxt

let freeze_rolls_for_cycle ctxt cycle =
  Storage.Roll.Snapshot_for_cycle.get ctxt cycle
  >>=? fun max_index ->
  Storage.Seed.For_cycle.get ctxt cycle
  >>=? fun seed ->
  let rd = Seed_repr.initialize_new seed [MBytes.of_string "roll_snapshot"] in
  let seq = Seed_repr.sequence rd 0l in
  let selected_index =
    Seed_repr.take_int32 seq (Int32.of_int max_index) |> fst |> Int32.to_int
  in
  Storage.Roll.Snapshot_for_cycle.set ctxt cycle selected_index
  >>=? fun ctxt ->
  fold_left_s
    (fun ctxt index ->
      if Compare.Int.(index = selected_index) then return ctxt
      else
        Storage.Roll.Owner.delete_snapshot ctxt (cycle, index)
        >>= fun ctxt ->
        Storage.Roll.Last_for_snapshot.delete (ctxt, cycle) index
        >>=? fun ctxt -> return ctxt)
    ctxt
    Misc.(0 --> (max_index - 1))
  >>=? fun ctxt -> return ctxt

(* Roll selection *)

module Random = struct
  let int32_to_bytes i =
    let b = MBytes.create 4 in
    MBytes.set_int32 b 0 i ; b

  let level_random seed use level =
    let position = level.Level_repr.cycle_position in
    Seed_repr.initialize_new
      seed
      [MBytes.of_string ("level " ^ use ^ ":"); int32_to_bytes position]

  let owner c kind level offset =
    let cycle = level.Level_repr.cycle in
    Seed_storage.for_cycle c cycle
    >>=? fun random_seed ->
    let rd = level_random random_seed kind level in
    let sequence = Seed_repr.sequence rd (Int32.of_int offset) in
    Storage.Roll.Snapshot_for_cycle.get c cycle
    >>=? fun index ->
    Storage.Roll.Last_for_snapshot.get (c, cycle) index
    >>=? fun bound ->
    let rec loop sequence =
      let (roll, sequence) = Roll_repr.random sequence ~bound in
      Storage.Roll.Owner.Snapshot.get_option c ((cycle, index), roll)
      >>=? function None -> loop sequence | Some delegate -> return delegate
    in
    Storage.Roll.Owner.snapshot_exists c (cycle, index)
    >>= fun snapshot_exists ->
    fail_unless snapshot_exists (No_roll_snapshot_for_cycle cycle)
    >>=? fun () -> loop sequence
end

let baking_rights_owner c level ~priority =
  Random.owner c "baking" level priority

let endorsement_rights_owner c level ~slot =
  Random.owner c "endorsement" level slot

let traverse_rolls ctxt head =
  let rec loop acc roll =
    Storage.Roll.Successor.get_option ctxt roll
    >>=? function
    | None -> return (List.rev acc) | Some next -> loop (next :: acc) next
  in
  loop [head] head

let get_rolls ctxt delegate =
  Storage.Roll.Delegate_roll_list.get_option ctxt delegate
  >>=? function
  | None -> return_nil | Some head_roll -> traverse_rolls ctxt head_roll

let count_rolls ctxt delegate =
  Storage.Roll.Delegate_roll_list.get_option ctxt delegate
  >>=? function
  | None ->
      return 0
  | Some head_roll ->
      let rec loop acc roll =
        Storage.Roll.Successor.get_option ctxt roll
        >>=? function None -> return acc | Some next -> loop (succ acc) next
      in
      loop 1 head_roll

let get_change c delegate =
  Storage.Roll.Delegate_change.get_option c delegate
  >>=? function None -> return Tez_repr.zero | Some change -> return change

module Delegate = struct
  let fresh_roll c =
    Storage.Roll.Next.get c
    >>=? fun roll ->
    Storage.Roll.Next.set c (Roll_repr.succ roll) >>=? fun c -> return (roll, c)

  let get_limbo_roll c =
    Storage.Roll.Limbo.get_option c
    >>=? function
    | None ->
        fresh_roll c
        >>=? fun (roll, c) ->
        Storage.Roll.Limbo.init c roll >>=? fun c -> return (roll, c)
    | Some roll ->
        return (roll, c)

  let consume_roll_change c delegate =
    let tokens_per_roll = Constants_storage.tokens_per_roll c in
    Storage.Roll.Delegate_change.get c delegate
    >>=? fun change ->
    trace Consume_roll_change (Lwt.return Tez_repr.(change -? tokens_per_roll))
    >>=? fun new_change ->
    Storage.Roll.Delegate_change.set c delegate new_change

  let recover_roll_change c delegate =
    let tokens_per_roll = Constants_storage.tokens_per_roll c in
    Storage.Roll.Delegate_change.get c delegate
    >>=? fun change ->
    Lwt.return Tez_repr.(change +? tokens_per_roll)
    >>=? fun new_change ->
    Storage.Roll.Delegate_change.set c delegate new_change

  let pop_roll_from_delegate c delegate =
    recover_roll_change c delegate
    >>=? fun c ->
    (* beginning:
       delegate : roll -> successor_roll -> ...
       limbo : limbo_head -> ...
    *)
    Storage.Roll.Limbo.get_option c
    >>=? fun limbo_head ->
    Storage.Roll.Delegate_roll_list.get_option c delegate
    >>=? function
    | None ->
        fail No_roll_for_delegate
    | Some roll ->
        Storage.Roll.Owner.delete c roll
        >>=? fun c ->
        Storage.Roll.Successor.get_option c roll
        >>=? fun successor_roll ->
        Storage.Roll.Delegate_roll_list.set_option c delegate successor_roll
        >>= fun c ->
        (* delegate : successor_roll -> ...
           roll ------^
           limbo : limbo_head -> ... *)
        Storage.Roll.Successor.set_option c roll limbo_head
        >>= fun c ->
        (* delegate : successor_roll -> ...
           roll ------v
           limbo : limbo_head -> ... *)
        Storage.Roll.Limbo.init_set c roll
        >>= fun c ->
        (* delegate : successor_roll -> ...
           limbo : roll -> limbo_head -> ... *)
        return (roll, c)

  let create_roll_in_delegate c delegate delegate_pk =
    consume_roll_change c delegate
    >>=? fun c ->
    (* beginning:
       delegate : delegate_head -> ...
       limbo : roll -> limbo_successor -> ...
    *)
    Storage.Roll.Delegate_roll_list.get_option c delegate
    >>=? fun delegate_head ->
    get_limbo_roll c
    >>=? fun (roll, c) ->
    Storage.Roll.Owner.init c roll delegate_pk
    >>=? fun c ->
    Storage.Roll.Successor.get_option c roll
    >>=? fun limbo_successor ->
    Storage.Roll.Limbo.set_option c limbo_successor
    >>= fun c ->
    (* delegate : delegate_head -> ...
       roll ------v
       limbo : limbo_successor -> ... *)
    Storage.Roll.Successor.set_option c roll delegate_head
    >>= fun c ->
    (* delegate : delegate_head -> ...
       roll ------^
       limbo : limbo_successor -> ... *)
    Storage.Roll.Delegate_roll_list.init_set c delegate roll
    >>= fun c ->
    (* delegate : roll -> delegate_head -> ...
       limbo : limbo_successor -> ... *)
    return c

  let ensure_inited c delegate =
    Storage.Roll.Delegate_change.mem c delegate
    >>= function
    | true ->
        return c
    | false ->
        Storage.Roll.Delegate_change.init c delegate Tez_repr.zero

  let is_inactive c delegate =
    Storage.Contract.Inactive_delegate.mem
      c
      (Contract_repr.implicit_contract delegate)
    >>= fun inactive ->
    if inactive then return inactive
    else
      Storage.Contract.Delegate_desactivation.get_option
        c
        (Contract_repr.implicit_contract delegate)
      >>=? function
      | Some last_active_cycle ->
          let {Level_repr.cycle = current_cycle} =
            Raw_context.current_level c
          in
          return Cycle_repr.(last_active_cycle < current_cycle)
      | None ->
          (* This case is only when called from `set_active`, when creating
             a contract. *)
          return_false

  let add_amount c delegate amount =
    ensure_inited c delegate
    >>=? fun c ->
    let tokens_per_roll = Constants_storage.tokens_per_roll c in
    Storage.Roll.Delegate_change.get c delegate
    >>=? fun change ->
    Lwt.return Tez_repr.(amount +? change)
    >>=? fun change ->
    Storage.Roll.Delegate_change.set c delegate change
    >>=? fun c ->
    delegate_pubkey c delegate
    >>=? fun delegate_pk ->
    let rec loop c change =
      if Tez_repr.(change < tokens_per_roll) then return c
      else
        Lwt.return Tez_repr.(change -? tokens_per_roll)
        >>=? fun change ->
        create_roll_in_delegate c delegate delegate_pk
        >>=? fun c -> loop c change
    in
    is_inactive c delegate
    >>=? fun inactive ->
    if inactive then return c
    else
      loop c change
      >>=? fun c ->
      Storage.Roll.Delegate_roll_list.get_option c delegate
      >>=? fun rolls ->
      match rolls with
      | None ->
          return c
      | Some _ ->
          Storage.Active_delegates_with_rolls.add c delegate
          >>= fun c -> return c

  let remove_amount c delegate amount =
    let tokens_per_roll = Constants_storage.tokens_per_roll c in
    let rec loop c change =
      if Tez_repr.(amount <= change) then return (c, change)
      else
        pop_roll_from_delegate c delegate
        >>=? fun (_, c) ->
        Lwt.return Tez_repr.(change +? tokens_per_roll)
        >>=? fun change -> loop c change
    in
    Storage.Roll.Delegate_change.get c delegate
    >>=? fun change ->
    is_inactive c delegate
    >>=? fun inactive ->
    ( if inactive then return (c, change)
    else
      loop c change
      >>=? fun (c, change) ->
      Storage.Roll.Delegate_roll_list.get_option c delegate
      >>=? fun rolls ->
      match rolls with
      | None ->
          Storage.Active_delegates_with_rolls.del c delegate
          >>= fun c -> return (c, change)
      | Some _ ->
          return (c, change) )
    >>=? fun (c, change) ->
    Lwt.return Tez_repr.(change -? amount)
    >>=? fun change -> Storage.Roll.Delegate_change.set c delegate change

  let set_inactive ctxt delegate =
    ensure_inited ctxt delegate
    >>=? fun ctxt ->
    let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in
    Storage.Roll.Delegate_change.get ctxt delegate
    >>=? fun change ->
    Storage.Contract.Inactive_delegate.add
      ctxt
      (Contract_repr.implicit_contract delegate)
    >>= fun ctxt ->
    Storage.Active_delegates_with_rolls.del ctxt delegate
    >>= fun ctxt ->
    let rec loop ctxt change =
      Storage.Roll.Delegate_roll_list.get_option ctxt delegate
      >>=? function
      | None ->
          return (ctxt, change)
      | Some _roll ->
          pop_roll_from_delegate ctxt delegate
          >>=? fun (_, ctxt) ->
          Lwt.return Tez_repr.(change +? tokens_per_roll)
          >>=? fun change -> loop ctxt change
    in
    loop ctxt change
    >>=? fun (ctxt, change) ->
    Storage.Roll.Delegate_change.set ctxt delegate change
    >>=? fun ctxt -> return ctxt

  let set_active ctxt delegate =
    is_inactive ctxt delegate
    >>=? fun inactive ->
    let current_cycle = (Raw_context.current_level ctxt).cycle in
    let preserved_cycles = Constants_storage.preserved_cycles ctxt in
    (* When the delegate is new or inactive, she will become active in
       `1+preserved_cycles`, and we allow `preserved_cycles` for the
       delegate to start baking. When the delegate is active, we only
       give her at least `preserved_cycles` after the current cycle
       before to be deactivated.  *)
    Storage.Contract.Delegate_desactivation.get_option
      ctxt
      (Contract_repr.implicit_contract delegate)
    >>=? fun current_expiration ->
    let expiration =
      match current_expiration with
      | None ->
          Cycle_repr.add current_cycle (1 + (2 * preserved_cycles))
      | Some current_expiration ->
          let delay =
            if inactive then 1 + (2 * preserved_cycles)
            else 1 + preserved_cycles
          in
          let updated = Cycle_repr.add current_cycle delay in
          Cycle_repr.max current_expiration updated
    in
    Storage.Contract.Delegate_desactivation.init_set
      ctxt
      (Contract_repr.implicit_contract delegate)
      expiration
    >>= fun ctxt ->
    if not inactive then return ctxt
    else
      ensure_inited ctxt delegate
      >>=? fun ctxt ->
      let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in
      Storage.Roll.Delegate_change.get ctxt delegate
      >>=? fun change ->
      Storage.Contract.Inactive_delegate.del
        ctxt
        (Contract_repr.implicit_contract delegate)
      >>= fun ctxt ->
      delegate_pubkey ctxt delegate
      >>=? fun delegate_pk ->
      let rec loop ctxt change =
        if Tez_repr.(change < tokens_per_roll) then return ctxt
        else
          Lwt.return Tez_repr.(change -? tokens_per_roll)
          >>=? fun change ->
          create_roll_in_delegate ctxt delegate delegate_pk
          >>=? fun ctxt -> loop ctxt change
      in
      loop ctxt change
      >>=? fun ctxt ->
      Storage.Roll.Delegate_roll_list.get_option ctxt delegate
      >>=? fun rolls ->
      match rolls with
      | None ->
          return ctxt
      | Some _ ->
          Storage.Active_delegates_with_rolls.add ctxt delegate
          >>= fun ctxt -> return ctxt
end

module Contract = struct
  let add_amount c contract amount =
    get_contract_delegate c contract
    >>=? function
    | None -> return c | Some delegate -> Delegate.add_amount c delegate amount

  let remove_amount c contract amount =
    get_contract_delegate c contract
    >>=? function
    | None ->
        return c
    | Some delegate ->
        Delegate.remove_amount c delegate amount
end

let init ctxt = Storage.Roll.Next.init ctxt Roll_repr.first

let init_first_cycles ctxt =
  let preserved = Constants_storage.preserved_cycles ctxt in
  (* Precompute rolls for cycle (0 --> preserved_cycles) *)
  List.fold_left
    (fun ctxt c ->
      ctxt
      >>=? fun ctxt ->
      let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in
      Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0
      >>=? fun ctxt ->
      snapshot_rolls_for_cycle ctxt cycle
      >>=? fun ctxt -> freeze_rolls_for_cycle ctxt cycle)
    (return ctxt)
    (0 --> preserved)
  >>=? fun ctxt ->
  let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 1)) in
  (* Precomputed a snapshot for cycle (preserved_cycles + 1) *)
  Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0
  >>=? fun ctxt ->
  snapshot_rolls_for_cycle ctxt cycle
  >>=? fun ctxt ->
  (* Prepare storage for storing snapshots for cycle (preserved_cycles+2) *)
  let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 2)) in
  Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0
  >>=? fun ctxt -> return ctxt

let snapshot_rolls ctxt =
  let current_level = Raw_context.current_level ctxt in
  let preserved = Constants_storage.preserved_cycles ctxt in
  let cycle = Cycle_repr.add current_level.cycle (preserved + 2) in
  snapshot_rolls_for_cycle ctxt cycle

let cycle_end ctxt last_cycle =
  let preserved = Constants_storage.preserved_cycles ctxt in
  ( match Cycle_repr.sub last_cycle preserved with
  | None ->
      return ctxt
  | Some cleared_cycle ->
      clear_cycle ctxt cleared_cycle )
  >>=? fun ctxt ->
  let frozen_roll_cycle = Cycle_repr.add last_cycle (preserved + 1) in
  freeze_rolls_for_cycle ctxt frozen_roll_cycle
  >>=? fun ctxt ->
  Storage.Roll.Snapshot_for_cycle.init
    ctxt
    (Cycle_repr.succ (Cycle_repr.succ frozen_roll_cycle))
    0
  >>=? fun ctxt -> return ctxt

let update_tokens_per_roll ctxt new_tokens_per_roll =
  let constants = Raw_context.constants ctxt in
  let old_tokens_per_roll = constants.tokens_per_roll in
  Raw_context.patch_constants ctxt (fun constants ->
      {constants with Constants_repr.tokens_per_roll = new_tokens_per_roll})
  >>= fun ctxt ->
  let decrease = Tez_repr.(new_tokens_per_roll < old_tokens_per_roll) in
  ( if decrease then
    Lwt.return Tez_repr.(old_tokens_per_roll -? new_tokens_per_roll)
  else Lwt.return Tez_repr.(new_tokens_per_roll -? old_tokens_per_roll) )
  >>=? fun abs_diff ->
  Storage.Delegates.fold ctxt (Ok ctxt) (fun pkh ctxt ->
      Lwt.return ctxt
      >>=? fun ctxt ->
      count_rolls ctxt pkh
      >>=? fun rolls ->
      Lwt.return Tez_repr.(abs_diff *? Int64.of_int rolls)
      >>=? fun amount ->
      if decrease then Delegate.add_amount ctxt pkh amount
      else Delegate.remove_amount ctxt pkh amount)
Roll_storage.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Constants_repr.
Require Tezos.Constants_storage.
Require Tezos.Contract_repr.
Require Tezos.Cycle_repr.
Require Tezos.Level_repr.
Require Tezos.Manager_repr.
Require Tezos.Misc.
Require Tezos.Raw_context.
Require Tezos.Roll_repr.
Require Tezos.Seed_repr.
Require Tezos.Seed_storage.
Require Tezos.Storage.
Require Tezos.Tez_repr.

Import Misc.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition get_contract_delegate
  (c : Storage.Contract.Delegate.context)
  (contract : Storage.Contract.Delegate.key)
  : Lwt.t (Error_monad.tzresult (option Storage.Contract.Delegate.value)) :=
  Storage.Contract.Delegate.get_option c contract.

Definition delegate_pubkey
  (ctxt : Storage.Contract.Manager.context)
  (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
  : Lwt.t (Error_monad.tzresult (|Signature.Public_key|).(S.SPublic_key.t)) :=
  Error_monad.op_gtgteqquestion
    (Storage.Contract.Manager.get_option ctxt
      (Contract_repr.implicit_contract delegate))
    (fun function_parameter =>
      match function_parameter with
      | None | Some (Manager_repr.Hash _) =>
        Error_monad.fail extensible_type_value
      | Some (Manager_repr.Public_key pk) => Error_monad.__return pk
      end).

Definition clear_cycle
  (c : Storage.Roll.Snapshot_for_cycle.context)
  (cycle : Storage.Roll.Snapshot_for_cycle.key)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Error_monad.op_gtgteqquestion (Storage.Roll.Snapshot_for_cycle.get c cycle)
    (fun index =>
      Error_monad.op_gtgteqquestion
        (Storage.Roll.Snapshot_for_cycle.delete c cycle)
        (fun c =>
          Error_monad.op_gtgteqquestion
            (Storage.Roll.Last_for_snapshot.delete (c, cycle) index)
            (fun c =>
              Error_monad.op_gtgteq
                (Storage.Roll.Owner.delete_snapshot c (cycle, index))
                (fun c => Error_monad.__return c)))).

Definition fold {A : Set}
  (ctxt : Storage.Roll.Next.context)
  (f :
    Roll_repr.roll -> Storage.Roll.Owner.value -> A ->
    Lwt.t (Error_monad.tzresult A)) (init : A)
  : Lwt.t (Error_monad.tzresult A) :=
  Error_monad.op_gtgteqquestion (Storage.Roll.Next.get ctxt)
    (fun last =>
      let fix loop
        (ctxt : Storage.Roll.Owner.context) (roll : Roll_repr.roll)
        (acc : Lwt.t (Error_monad.tzresult A)) {struct ctxt}
        : Lwt.t (Error_monad.tzresult A) :=
        Error_monad.op_gtgteqquestion acc
          (fun acc =>
            if Roll_repr.op_eq roll last then
              Error_monad.__return acc
            else
              Error_monad.op_gtgteqquestion
                (Storage.Roll.Owner.get_option ctxt roll)
                (fun function_parameter =>
                  match function_parameter with
                  | None =>
                    loop ctxt (Roll_repr.succ roll) (Error_monad.__return acc)
                  | Some delegate =>
                    loop ctxt (Roll_repr.succ roll) (f roll delegate acc)
                  end)) in
      loop ctxt Roll_repr.first (Error_monad.__return init)).

Definition snapshot_rolls_for_cycle
  (ctxt : Storage.Roll.Snapshot_for_cycle.context)
  (cycle : Storage.Roll.Snapshot_for_cycle.key)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Error_monad.op_gtgteqquestion (Storage.Roll.Snapshot_for_cycle.get ctxt cycle)
    (fun index =>
      Error_monad.op_gtgteqquestion
        (Storage.Roll.Snapshot_for_cycle.set ctxt cycle
          (Pervasives.op_plus index 1))
        (fun ctxt =>
          Error_monad.op_gtgteqquestion
            (Storage.Roll.Owner.__snapshot_value ctxt (cycle, index))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion (Storage.Roll.Next.get ctxt)
                (fun last =>
                  Error_monad.op_gtgteqquestion
                    (Storage.Roll.Last_for_snapshot.init (ctxt, cycle) index
                      last) (fun ctxt => Error_monad.__return ctxt))))).

Definition freeze_rolls_for_cycle
  (ctxt : Storage.Roll.Snapshot_for_cycle.context)
  (cycle : Storage.Roll.Snapshot_for_cycle.key)
  : Lwt.t (Error_monad.tzresult Storage.Roll.Owner.context) :=
  Error_monad.op_gtgteqquestion (Storage.Roll.Snapshot_for_cycle.get ctxt cycle)
    (fun max_index =>
      Error_monad.op_gtgteqquestion (Storage.Seed.For_cycle.get ctxt cycle)
        (fun __seed_value =>
          let rd :=
            Seed_repr.initialize_new __seed_value
              [ MBytes.of_string "roll_snapshot" ] in
          let seq :=
            Seed_repr.__sequence_value rd
              (* ❌ Constant of type int32 is converted to int *)
              0 in
          let selected_index :=
            Pervasives.op_pipegt
              (Pervasives.op_pipegt
                (Seed_repr.take_int32 seq (Int32.of_int max_index))
                Pervasives.fst) Int32.to_int in
          Error_monad.op_gtgteqquestion
            (Storage.Roll.Snapshot_for_cycle.set ctxt cycle selected_index)
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (Error_monad.fold_left_s
                  (fun ctxt =>
                    fun index =>
                      if (|Compare.Int|).(Compare.S.op_eq) index selected_index
                        then
                        Error_monad.__return ctxt
                      else
                        Error_monad.op_gtgteq
                          (Storage.Roll.Owner.delete_snapshot ctxt
                            (cycle, index))
                          (fun ctxt =>
                            Error_monad.op_gtgteqquestion
                              (Storage.Roll.Last_for_snapshot.delete
                                (ctxt, cycle) index)
                              (fun ctxt => Error_monad.__return ctxt))) ctxt
                  (Misc.op_minusminusgt 0 (Pervasives.op_minus max_index 1)))
                (fun ctxt => Error_monad.__return ctxt)))).

Module Random.
  Definition int32_to_bytes (i : int32) : MBytes.t :=
    let b := MBytes.create 4 in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    (* ❌ instruction_sequence ";" *)
    b.
  
  Definition level_random
    (__seed_value : Seed_repr.seed) (use : string) (level : Level_repr.t)
    : Seed_repr.t :=
    let position := Level_repr.t.cycle_position level in
    Seed_repr.initialize_new __seed_value
      [
        MBytes.of_string
          (Pervasives.op_caret "level " (Pervasives.op_caret use ":"));
        int32_to_bytes position
      ].
  
  Definition owner
    (c : Raw_context.t) (kind : string) (level : Level_repr.t) (offset : Z)
    : Lwt.t (Error_monad.tzresult Storage.Roll.Owner.Snapshot.value) :=
    let cycle := Level_repr.t.cycle level in
    Error_monad.op_gtgteqquestion (Seed_storage.for_cycle c cycle)
      (fun random_seed =>
        let rd := level_random random_seed kind level in
        let __sequence_value :=
          Seed_repr.__sequence_value rd (Int32.of_int offset) in
        Error_monad.op_gtgteqquestion
          (Storage.Roll.Snapshot_for_cycle.get c cycle)
          (fun index =>
            Error_monad.op_gtgteqquestion
              (Storage.Roll.Last_for_snapshot.get (c, cycle) index)
              (fun bound =>
                let fix loop (__sequence_value : Seed_repr.sequence)
                  {struct __sequence_value}
                  : Lwt.t
                    (Error_monad.tzresult Storage.Roll.Owner.Snapshot.value) :=
                  let '(roll, __sequence_value) :=
                    Roll_repr.random __sequence_value bound in
                  Error_monad.op_gtgteqquestion
                    (Storage.Roll.Owner.Snapshot.get_option c
                      ((cycle, index), roll))
                    (fun function_parameter =>
                      match function_parameter with
                      | None => loop __sequence_value
                      | Some delegate => Error_monad.__return delegate
                      end) in
                Error_monad.op_gtgteq
                  (Storage.Roll.Owner.snapshot_exists c (cycle, index))
                  (fun snapshot_exists =>
                    Error_monad.op_gtgteqquestion
                      (Error_monad.fail_unless snapshot_exists
                        extensible_type_value)
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        loop __sequence_value))))).
End Random.

Definition baking_rights_owner
  (c : Raw_context.t) (level : Level_repr.t) (priority : Z)
  : Lwt.t (Error_monad.tzresult Storage.Roll.Owner.Snapshot.value) :=
  Random.owner c "baking" level priority.

Definition endorsement_rights_owner
  (c : Raw_context.t) (level : Level_repr.t) (slot : Z)
  : Lwt.t (Error_monad.tzresult Storage.Roll.Owner.Snapshot.value) :=
  Random.owner c "endorsement" level slot.

Definition traverse_rolls
  (ctxt : Storage.Roll.Successor.context) (head : Storage.Roll.Successor.value)
  : Lwt.t (Error_monad.tzresult (list Storage.Roll.Successor.value)) :=
  let fix loop
    (acc : list Storage.Roll.Successor.value)
    (roll : Storage.Roll.Successor.key) {struct acc}
    : Lwt.t (Error_monad.tzresult (list Storage.Roll.Successor.value)) :=
    Error_monad.op_gtgteqquestion (Storage.Roll.Successor.get_option ctxt roll)
      (fun function_parameter =>
        match function_parameter with
        | None => Error_monad.__return (List.rev acc)
        | Some next => loop (cons next acc) next
        end) in
  loop [ head ] head.

Definition get_rolls
  (ctxt : Storage.Roll.Delegate_roll_list.context)
  (delegate : Storage.Roll.Delegate_roll_list.key)
  : Lwt.t (Error_monad.tzresult (list Storage.Roll.Successor.value)) :=
  Error_monad.op_gtgteqquestion
    (Storage.Roll.Delegate_roll_list.get_option ctxt delegate)
    (fun function_parameter =>
      match function_parameter with
      | None => Error_monad.return_nil
      | Some head_roll => traverse_rolls ctxt head_roll
      end).

Definition count_rolls
  (ctxt : Storage.Roll.Delegate_roll_list.context)
  (delegate : Storage.Roll.Delegate_roll_list.key)
  : Lwt.t (Error_monad.tzresult Z) :=
  Error_monad.op_gtgteqquestion
    (Storage.Roll.Delegate_roll_list.get_option ctxt delegate)
    (fun function_parameter =>
      match function_parameter with
      | None => Error_monad.__return 0
      | Some head_roll =>
        let fix loop (acc : Z) (roll : Storage.Roll.Successor.key) {struct acc}
          : Lwt.t (Error_monad.tzresult Z) :=
          Error_monad.op_gtgteqquestion
            (Storage.Roll.Successor.get_option ctxt roll)
            (fun function_parameter =>
              match function_parameter with
              | None => Error_monad.__return acc
              | Some next => loop (Pervasives.succ acc) next
              end) in
        loop 1 head_roll
      end).

Definition get_change
  (c : Storage.Roll.Delegate_change.context)
  (delegate : Storage.Roll.Delegate_change.key)
  : Lwt.t (Error_monad.tzresult Tez_repr.t) :=
  Error_monad.op_gtgteqquestion
    (Storage.Roll.Delegate_change.get_option c delegate)
    (fun function_parameter =>
      match function_parameter with
      | None => Error_monad.__return Tez_repr.zero
      | Some change => Error_monad.__return change
      end).

Module Delegate.
  Definition fresh_roll (c : Storage.Roll.Next.context)
    : Lwt.t (Error_monad.tzresult (Storage.Roll.Next.value * Raw_context.t)) :=
    Error_monad.op_gtgteqquestion (Storage.Roll.Next.get c)
      (fun roll =>
        Error_monad.op_gtgteqquestion
          (Storage.Roll.Next.set c (Roll_repr.succ roll))
          (fun c => Error_monad.__return (roll, c))).
  
  Definition get_limbo_roll (c : Storage.Roll.Limbo.context)
    : Lwt.t (Error_monad.tzresult (Storage.Roll.Next.value * Raw_context.t)) :=
    Error_monad.op_gtgteqquestion (Storage.Roll.Limbo.get_option c)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          Error_monad.op_gtgteqquestion (fresh_roll c)
            (fun function_parameter =>
              let '(roll, c) := function_parameter in
              Error_monad.op_gtgteqquestion (Storage.Roll.Limbo.init c roll)
                (fun c => Error_monad.__return (roll, c)))
        | Some roll => Error_monad.__return (roll, c)
        end).
  
  Definition consume_roll_change
    (c : Raw_context.context) (delegate : Storage.Roll.Delegate_change.key)
    : Lwt.t (Error_monad.tzresult Raw_context.t) :=
    let tokens_per_roll := Constants_storage.tokens_per_roll c in
    Error_monad.op_gtgteqquestion (Storage.Roll.Delegate_change.get c delegate)
      (fun change =>
        Error_monad.op_gtgteqquestion
          (Error_monad.trace extensible_type_value
            (Lwt.__return (Tez_repr.op_minusquestion change tokens_per_roll)))
          (fun new_change =>
            Storage.Roll.Delegate_change.set c delegate new_change)).
  
  Definition recover_roll_change
    (c : Raw_context.context) (delegate : Storage.Roll.Delegate_change.key)
    : Lwt.t (Error_monad.tzresult Raw_context.t) :=
    let tokens_per_roll := Constants_storage.tokens_per_roll c in
    Error_monad.op_gtgteqquestion (Storage.Roll.Delegate_change.get c delegate)
      (fun change =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Tez_repr.op_plusquestion change tokens_per_roll))
          (fun new_change =>
            Storage.Roll.Delegate_change.set c delegate new_change)).
  
  Definition pop_roll_from_delegate
    (c : Raw_context.context) (delegate : Storage.Roll.Delegate_change.key)
    : Lwt.t
      (Error_monad.tzresult
        (Storage.Roll.Delegate_roll_list.value * Raw_context.t)) :=
    Error_monad.op_gtgteqquestion (recover_roll_change c delegate)
      (fun c =>
        Error_monad.op_gtgteqquestion (Storage.Roll.Limbo.get_option c)
          (fun limbo_head =>
            Error_monad.op_gtgteqquestion
              (Storage.Roll.Delegate_roll_list.get_option c delegate)
              (fun function_parameter =>
                match function_parameter with
                | None => Error_monad.fail extensible_type_value
                | Some roll =>
                  Error_monad.op_gtgteqquestion
                    (Storage.Roll.Owner.delete c roll)
                    (fun c =>
                      Error_monad.op_gtgteqquestion
                        (Storage.Roll.Successor.get_option c roll)
                        (fun successor_roll =>
                          Error_monad.op_gtgteq
                            (Storage.Roll.Delegate_roll_list.set_option c
                              delegate successor_roll)
                            (fun c =>
                              Error_monad.op_gtgteq
                                (Storage.Roll.Successor.set_option c roll
                                  limbo_head)
                                (fun c =>
                                  Error_monad.op_gtgteq
                                    (Storage.Roll.Limbo.init_set c roll)
                                    (fun c => Error_monad.__return (roll, c))))))
                end))).
  
  Definition create_roll_in_delegate
    (c : Raw_context.context) (delegate : Storage.Roll.Delegate_change.key)
    (delegate_pk : Storage.Roll.Owner.value)
    : Lwt.t (Error_monad.tzresult Raw_context.t) :=
    Error_monad.op_gtgteqquestion (consume_roll_change c delegate)
      (fun c =>
        Error_monad.op_gtgteqquestion
          (Storage.Roll.Delegate_roll_list.get_option c delegate)
          (fun delegate_head =>
            Error_monad.op_gtgteqquestion (get_limbo_roll c)
              (fun function_parameter =>
                let '(roll, c) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Storage.Roll.Owner.init c roll delegate_pk)
                  (fun c =>
                    Error_monad.op_gtgteqquestion
                      (Storage.Roll.Successor.get_option c roll)
                      (fun limbo_successor =>
                        Error_monad.op_gtgteq
                          (Storage.Roll.Limbo.set_option c limbo_successor)
                          (fun c =>
                            Error_monad.op_gtgteq
                              (Storage.Roll.Successor.set_option c roll
                                delegate_head)
                              (fun c =>
                                Error_monad.op_gtgteq
                                  (Storage.Roll.Delegate_roll_list.init_set c
                                    delegate roll)
                                  (fun c => Error_monad.__return c)))))))).
  
  Definition ensure_inited
    (c : Storage.Roll.Delegate_change.context)
    (delegate : Storage.Roll.Delegate_change.key)
    : Lwt.t (Error_monad.tzresult Storage.Roll.Delegate_change.context) :=
    Error_monad.op_gtgteq (Storage.Roll.Delegate_change.mem c delegate)
      (fun function_parameter =>
        match function_parameter with
        | true => Error_monad.__return c
        | false => Storage.Roll.Delegate_change.init c delegate Tez_repr.zero
        end).
  
  Definition is_inactive
    (c : Storage.Contract.Inactive_delegate.context)
    (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
    : Lwt.t (Error_monad.tzresult bool) :=
    Error_monad.op_gtgteq
      (Storage.Contract.Inactive_delegate.mem c
        (Contract_repr.implicit_contract delegate))
      (fun inactive =>
        if inactive then
          Error_monad.__return inactive
        else
          Error_monad.op_gtgteqquestion
            (Storage.Contract.Delegate_desactivation.get_option c
              (Contract_repr.implicit_contract delegate))
            (fun function_parameter =>
              match function_parameter with
              | Some last_active_cycle =>
                let '{| Level_repr.t.cycle := current_cycle |} :=
                  Raw_context.current_level c in
                Error_monad.__return
                  (Cycle_repr.op_lt last_active_cycle current_cycle)
              | None => Error_monad.return_false
              end)).
  
  Definition add_amount
    (c : Storage.Roll.Delegate_change.context)
    (delegate : Storage.Roll.Delegate_change.key) (amount : Tez_repr.t)
    : Lwt.t (Error_monad.tzresult Raw_context.t) :=
    Error_monad.op_gtgteqquestion (ensure_inited c delegate)
      (fun c =>
        let tokens_per_roll := Constants_storage.tokens_per_roll c in
        Error_monad.op_gtgteqquestion
          (Storage.Roll.Delegate_change.get c delegate)
          (fun change =>
            Error_monad.op_gtgteqquestion
              (Lwt.__return (Tez_repr.op_plusquestion amount change))
              (fun change =>
                Error_monad.op_gtgteqquestion
                  (Storage.Roll.Delegate_change.set c delegate change)
                  (fun c =>
                    Error_monad.op_gtgteqquestion (delegate_pubkey c delegate)
                      (fun delegate_pk =>
                        let fix loop
                          (c : Raw_context.context) (change : Tez_repr.t)
                          {struct c}
                          : Lwt.t (Error_monad.tzresult Raw_context.context) :=
                          if Tez_repr.op_lt change tokens_per_roll then
                            Error_monad.__return c
                          else
                            Error_monad.op_gtgteqquestion
                              (Lwt.__return
                                (Tez_repr.op_minusquestion change
                                  tokens_per_roll))
                              (fun change =>
                                Error_monad.op_gtgteqquestion
                                  (create_roll_in_delegate c delegate
                                    delegate_pk) (fun c => loop c change)) in
                        Error_monad.op_gtgteqquestion (is_inactive c delegate)
                          (fun inactive =>
                            if inactive then
                              Error_monad.__return c
                            else
                              Error_monad.op_gtgteqquestion (loop c change)
                                (fun c =>
                                  Error_monad.op_gtgteqquestion
                                    (Storage.Roll.Delegate_roll_list.get_option
                                      c delegate)
                                    (fun rolls =>
                                      match rolls with
                                      | None => Error_monad.__return c
                                      | Some _ =>
                                        Error_monad.op_gtgteq
                                          (Storage.Active_delegates_with_rolls.add
                                            c delegate)
                                          (fun c => Error_monad.__return c)
                                      end)))))))).
  
  Definition remove_amount
    (c : Raw_context.context) (delegate : Storage.Roll.Delegate_change.key)
    (amount : Tez_repr.t) : Lwt.t (Error_monad.tzresult Raw_context.t) :=
    let tokens_per_roll := Constants_storage.tokens_per_roll c in
    let fix loop (c : Raw_context.context) (change : Tez_repr.t) {struct c}
      : Lwt.t (Error_monad.tzresult (Raw_context.context * Tez_repr.t)) :=
      if Tez_repr.op_lteq amount change then
        Error_monad.__return (c, change)
      else
        Error_monad.op_gtgteqquestion (pop_roll_from_delegate c delegate)
          (fun function_parameter =>
            let '(_, c) := function_parameter in
            Error_monad.op_gtgteqquestion
              (Lwt.__return (Tez_repr.op_plusquestion change tokens_per_roll))
              (fun change => loop c change)) in
    Error_monad.op_gtgteqquestion (Storage.Roll.Delegate_change.get c delegate)
      (fun change =>
        Error_monad.op_gtgteqquestion (is_inactive c delegate)
          (fun inactive =>
            Error_monad.op_gtgteqquestion
              (if inactive then
                Error_monad.__return (c, change)
              else
                Error_monad.op_gtgteqquestion (loop c change)
                  (fun function_parameter =>
                    let '(c, change) := function_parameter in
                    Error_monad.op_gtgteqquestion
                      (Storage.Roll.Delegate_roll_list.get_option c delegate)
                      (fun rolls =>
                        match rolls with
                        | None =>
                          Error_monad.op_gtgteq
                            (Storage.Active_delegates_with_rolls.del c delegate)
                            (fun c => Error_monad.__return (c, change))
                        | Some _ => Error_monad.__return (c, change)
                        end)))
              (fun function_parameter =>
                let '(c, change) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Lwt.__return (Tez_repr.op_minusquestion change amount))
                  (fun change =>
                    Storage.Roll.Delegate_change.set c delegate change)))).
  
  Definition set_inactive
    (ctxt : Storage.Roll.Delegate_change.context)
    (delegate : Storage.Roll.Delegate_change.key)
    : Lwt.t (Error_monad.tzresult Raw_context.t) :=
    Error_monad.op_gtgteqquestion (ensure_inited ctxt delegate)
      (fun ctxt =>
        let tokens_per_roll := Constants_storage.tokens_per_roll ctxt in
        Error_monad.op_gtgteqquestion
          (Storage.Roll.Delegate_change.get ctxt delegate)
          (fun change =>
            Error_monad.op_gtgteq
              (Storage.Contract.Inactive_delegate.add ctxt
                (Contract_repr.implicit_contract delegate))
              (fun ctxt =>
                Error_monad.op_gtgteq
                  (Storage.Active_delegates_with_rolls.del ctxt delegate)
                  (fun ctxt =>
                    let fix loop
                      (ctxt : Storage.Roll.Delegate_roll_list.context)
                      (change : Tez_repr.t) {struct ctxt}
                      : Lwt.t
                        (Error_monad.tzresult
                          (Storage.Roll.Delegate_roll_list.context * Tez_repr.t)) :=
                      Error_monad.op_gtgteqquestion
                        (Storage.Roll.Delegate_roll_list.get_option ctxt
                          delegate)
                        (fun function_parameter =>
                          match function_parameter with
                          | None => Error_monad.__return (ctxt, change)
                          | Some _roll =>
                            Error_monad.op_gtgteqquestion
                              (pop_roll_from_delegate ctxt delegate)
                              (fun function_parameter =>
                                let '(_, ctxt) := function_parameter in
                                Error_monad.op_gtgteqquestion
                                  (Lwt.__return
                                    (Tez_repr.op_plusquestion change
                                      tokens_per_roll))
                                  (fun change => loop ctxt change))
                          end) in
                    Error_monad.op_gtgteqquestion (loop ctxt change)
                      (fun function_parameter =>
                        let '(ctxt, change) := function_parameter in
                        Error_monad.op_gtgteqquestion
                          (Storage.Roll.Delegate_change.set ctxt delegate change)
                          (fun ctxt => Error_monad.__return ctxt)))))).
  
  Definition set_active
    (ctxt : Storage.Contract.Inactive_delegate.context)
    (delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))
    : Lwt.t (Error_monad.tzresult Raw_context.t) :=
    Error_monad.op_gtgteqquestion (is_inactive ctxt delegate)
      (fun inactive =>
        let current_cycle := Level_repr.t.cycle (Raw_context.current_level ctxt)
          in
        let preserved_cycles := Constants_storage.preserved_cycles ctxt in
        Error_monad.op_gtgteqquestion
          (Storage.Contract.Delegate_desactivation.get_option ctxt
            (Contract_repr.implicit_contract delegate))
          (fun current_expiration =>
            let expiration :=
              match current_expiration with
              | None =>
                Cycle_repr.add current_cycle
                  (Pervasives.op_plus 1 (Pervasives.op_star 2 preserved_cycles))
              | Some current_expiration =>
                let delay :=
                  if inactive then
                    Pervasives.op_plus 1 (Pervasives.op_star 2 preserved_cycles)
                  else
                    Pervasives.op_plus 1 preserved_cycles in
                let updated := Cycle_repr.add current_cycle delay in
                Cycle_repr.max current_expiration updated
              end in
            Error_monad.op_gtgteq
              (Storage.Contract.Delegate_desactivation.init_set ctxt
                (Contract_repr.implicit_contract delegate) expiration)
              (fun ctxt =>
                if Pervasives.not inactive then
                  Error_monad.__return ctxt
                else
                  Error_monad.op_gtgteqquestion (ensure_inited ctxt delegate)
                    (fun ctxt =>
                      let tokens_per_roll :=
                        Constants_storage.tokens_per_roll ctxt in
                      Error_monad.op_gtgteqquestion
                        (Storage.Roll.Delegate_change.get ctxt delegate)
                        (fun change =>
                          Error_monad.op_gtgteq
                            (Storage.Contract.Inactive_delegate.del ctxt
                              (Contract_repr.implicit_contract delegate))
                            (fun ctxt =>
                              Error_monad.op_gtgteqquestion
                                (delegate_pubkey ctxt delegate)
                                (fun delegate_pk =>
                                  let fix loop
                                    (ctxt : Raw_context.context)
                                    (change : Tez_repr.t) {struct ctxt}
                                    : Lwt.t
                                      (Error_monad.tzresult Raw_context.context) :=
                                    if Tez_repr.op_lt change tokens_per_roll
                                      then
                                      Error_monad.__return ctxt
                                    else
                                      Error_monad.op_gtgteqquestion
                                        (Lwt.__return
                                          (Tez_repr.op_minusquestion change
                                            tokens_per_roll))
                                        (fun change =>
                                          Error_monad.op_gtgteqquestion
                                            (create_roll_in_delegate ctxt
                                              delegate delegate_pk)
                                            (fun ctxt => loop ctxt change)) in
                                  Error_monad.op_gtgteqquestion
                                    (loop ctxt change)
                                    (fun ctxt =>
                                      Error_monad.op_gtgteqquestion
                                        (Storage.Roll.Delegate_roll_list.get_option
                                          ctxt delegate)
                                        (fun rolls =>
                                          match rolls with
                                          | None => Error_monad.__return ctxt
                                          | Some _ =>
                                            Error_monad.op_gtgteq
                                              (Storage.Active_delegates_with_rolls.add
                                                ctxt delegate)
                                              (fun ctxt =>
                                                Error_monad.__return ctxt)
                                          end))))))))).
End Delegate.

Module Contract.
  Definition add_amount
    (c : Storage.Contract.Delegate.context)
    (contract : Storage.Contract.Delegate.key) (amount : Tez_repr.t)
    : Lwt.t (Error_monad.tzresult Storage.Contract.Delegate.context) :=
    Error_monad.op_gtgteqquestion (get_contract_delegate c contract)
      (fun function_parameter =>
        match function_parameter with
        | None => Error_monad.__return c
        | Some delegate => Delegate.add_amount c delegate amount
        end).
  
  Definition remove_amount
    (c : Storage.Contract.Delegate.context)
    (contract : Storage.Contract.Delegate.key) (amount : Tez_repr.t)
    : Lwt.t (Error_monad.tzresult Storage.Contract.Delegate.context) :=
    Error_monad.op_gtgteqquestion (get_contract_delegate c contract)
      (fun function_parameter =>
        match function_parameter with
        | None => Error_monad.__return c
        | Some delegate => Delegate.remove_amount c delegate amount
        end).
End Contract.

Definition init (ctxt : Storage.Roll.Next.context)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Storage.Roll.Next.init ctxt Roll_repr.first.

Definition init_first_cycles (ctxt : Raw_context.context)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let preserved := Constants_storage.preserved_cycles ctxt in
  Error_monad.op_gtgteqquestion
    (List.fold_left
      (fun ctxt =>
        fun c =>
          Error_monad.op_gtgteqquestion ctxt
            (fun ctxt =>
              let cycle := Cycle_repr.of_int32_exn (Int32.of_int c) in
              Error_monad.op_gtgteqquestion
                (Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0)
                (fun ctxt =>
                  Error_monad.op_gtgteqquestion
                    (snapshot_rolls_for_cycle ctxt cycle)
                    (fun ctxt => freeze_rolls_for_cycle ctxt cycle))))
      (Error_monad.__return ctxt) (Misc.op_minusminusgt 0 preserved))
    (fun ctxt =>
      let cycle :=
        Cycle_repr.of_int32_exn (Int32.of_int (Pervasives.op_plus preserved 1))
        in
      Error_monad.op_gtgteqquestion
        (Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0)
        (fun ctxt =>
          Error_monad.op_gtgteqquestion (snapshot_rolls_for_cycle ctxt cycle)
            (fun ctxt =>
              let cycle :=
                Cycle_repr.of_int32_exn
                  (Int32.of_int (Pervasives.op_plus preserved 2)) in
              Error_monad.op_gtgteqquestion
                (Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0)
                (fun ctxt => Error_monad.__return ctxt)))).

Definition snapshot_rolls (ctxt : Raw_context.context)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let current_level := Raw_context.current_level ctxt in
  let preserved := Constants_storage.preserved_cycles ctxt in
  let cycle :=
    Cycle_repr.add (Level_repr.t.cycle current_level)
      (Pervasives.op_plus preserved 2) in
  snapshot_rolls_for_cycle ctxt cycle.

Definition cycle_end
  (ctxt : Raw_context.context) (last_cycle : Cycle_repr.cycle)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let preserved := Constants_storage.preserved_cycles ctxt in
  Error_monad.op_gtgteqquestion
    match Cycle_repr.sub last_cycle preserved with
    | None => Error_monad.__return ctxt
    | Some cleared_cycle => clear_cycle ctxt cleared_cycle
    end
    (fun ctxt =>
      let frozen_roll_cycle :=
        Cycle_repr.add last_cycle (Pervasives.op_plus preserved 1) in
      Error_monad.op_gtgteqquestion
        (freeze_rolls_for_cycle ctxt frozen_roll_cycle)
        (fun ctxt =>
          Error_monad.op_gtgteqquestion
            (Storage.Roll.Snapshot_for_cycle.init ctxt
              (Cycle_repr.succ (Cycle_repr.succ frozen_roll_cycle)) 0)
            (fun ctxt => Error_monad.__return ctxt))).

Definition update_tokens_per_roll
  (ctxt : Raw_context.context) (new_tokens_per_roll : Tez_repr.t)
  : Lwt.t (Error_monad.tzresult Raw_context.context) :=
  let constants := Raw_context.constants ctxt in
  let old_tokens_per_roll := Constants_repr.parametric.tokens_per_roll constants
    in
  Error_monad.op_gtgteq
    (Raw_context.patch_constants ctxt
      (fun constants =>
        Constants_repr.parametric.with_tokens_per_roll new_tokens_per_roll
          constants))
    (fun ctxt =>
      let decrease := Tez_repr.op_lt new_tokens_per_roll old_tokens_per_roll in
      Error_monad.op_gtgteqquestion
        (if decrease then
          Lwt.__return
            (Tez_repr.op_minusquestion old_tokens_per_roll new_tokens_per_roll)
        else
          Lwt.__return
            (Tez_repr.op_minusquestion new_tokens_per_roll old_tokens_per_roll))
        (fun abs_diff =>
          Storage.Delegates.fold ctxt (Pervasives.Ok ctxt)
            (fun pkh =>
              fun ctxt =>
                Error_monad.op_gtgteqquestion (Lwt.__return ctxt)
                  (fun ctxt =>
                    Error_monad.op_gtgteqquestion (count_rolls ctxt pkh)
                      (fun rolls =>
                        Error_monad.op_gtgteqquestion
                          (Lwt.__return
                            (Tez_repr.op_starquestion abs_diff
                              (Int64.of_int rolls)))
                          (fun amount =>
                            if decrease then
                              Delegate.add_amount ctxt pkh amount
                            else
                              Delegate.remove_amount ctxt pkh amount)))))).

Roll_storage_mli

  • OCaml size: 132 lines
  • Coq size: 97 lines (-27% compared to OCaml)
roll_storage.mli 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(**

   Basic roll manipulation.

   If storage related to roll (a.k.a. `Storage.Roll`) are not used
   outside of this module, this interface enforces the invariant that a
   roll is always either in the limbo list or in a contract list.

*)

type error +=
  | Consume_roll_change
  | No_roll_for_delegate
  | No_roll_snapshot_for_cycle of Cycle_repr.t
  | Unregistered_delegate of Signature.Public_key_hash.t

(* `Permanent *)

val init : Raw_context.t -> Raw_context.t tzresult Lwt.t

val init_first_cycles : Raw_context.t -> Raw_context.t tzresult Lwt.t

val cycle_end : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t

val snapshot_rolls : Raw_context.t -> Raw_context.t tzresult Lwt.t

val fold :
  Raw_context.t ->
  f:(Roll_repr.roll -> Signature.Public_key.t -> 'a -> 'a tzresult Lwt.t) ->
  'a ->
  'a tzresult Lwt.t

val baking_rights_owner :
  Raw_context.t ->
  Level_repr.t ->
  priority:int ->
  Signature.Public_key.t tzresult Lwt.t

val endorsement_rights_owner :
  Raw_context.t ->
  Level_repr.t ->
  slot:int ->
  Signature.Public_key.t tzresult Lwt.t

module Delegate : sig
  val is_inactive :
    Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t

  val add_amount :
    Raw_context.t ->
    Signature.Public_key_hash.t ->
    Tez_repr.t ->
    Raw_context.t tzresult Lwt.t

  val remove_amount :
    Raw_context.t ->
    Signature.Public_key_hash.t ->
    Tez_repr.t ->
    Raw_context.t tzresult Lwt.t

  val set_inactive :
    Raw_context.t ->
    Signature.Public_key_hash.t ->
    Raw_context.t tzresult Lwt.t

  val set_active :
    Raw_context.t ->
    Signature.Public_key_hash.t ->
    Raw_context.t tzresult Lwt.t
end

module Contract : sig
  val add_amount :
    Raw_context.t ->
    Contract_repr.t ->
    Tez_repr.t ->
    Raw_context.t tzresult Lwt.t

  val remove_amount :
    Raw_context.t ->
    Contract_repr.t ->
    Tez_repr.t ->
    Raw_context.t tzresult Lwt.t
end

val delegate_pubkey :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Signature.Public_key.t tzresult Lwt.t

val get_rolls :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Roll_repr.t list tzresult Lwt.t

val get_change :
  Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t

val update_tokens_per_roll :
  Raw_context.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t

(**/**)

val get_contract_delegate :
  Raw_context.t ->
  Contract_repr.t ->
  Signature.Public_key_hash.t option tzresult Lwt.t
Roll_storage_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Contract_repr.
Require Tezos.Cycle_repr.
Require Tezos.Level_repr.
Require Tezos.Raw_context.
Require Tezos.Roll_repr.
Require Tezos.Tez_repr.

(* extensible_type error *)

Parameter init : Raw_context.t -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter init_first_cycles :
  Raw_context.t -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter cycle_end :
  Raw_context.t -> Cycle_repr.t -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter snapshot_rolls :
  Raw_context.t -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter fold : forall {a : Set},
  Raw_context.t ->
  (Roll_repr.roll -> (|Signature.Public_key|).(S.SPublic_key.t) -> a ->
  Lwt.t (Error_monad.tzresult a)) -> a -> Lwt.t (Error_monad.tzresult a).

Parameter baking_rights_owner :
  Raw_context.t -> Level_repr.t -> Z ->
  Lwt.t (Error_monad.tzresult (|Signature.Public_key|).(S.SPublic_key.t)).

Parameter endorsement_rights_owner :
  Raw_context.t -> Level_repr.t -> Z ->
  Lwt.t (Error_monad.tzresult (|Signature.Public_key|).(S.SPublic_key.t)).

Module Delegate.
  Parameter is_inactive :
    Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
    Lwt.t (Error_monad.tzresult bool).
  
  Parameter add_amount :
    Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
    Tez_repr.t -> Lwt.t (Error_monad.tzresult Raw_context.t).
  
  Parameter remove_amount :
    Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
    Tez_repr.t -> Lwt.t (Error_monad.tzresult Raw_context.t).
  
  Parameter set_inactive :
    Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
    Lwt.t (Error_monad.tzresult Raw_context.t).
  
  Parameter set_active :
    Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
    Lwt.t (Error_monad.tzresult Raw_context.t).
End Delegate.

Module Contract.
  Parameter add_amount :
    Raw_context.t -> Contract_repr.t -> Tez_repr.t ->
    Lwt.t (Error_monad.tzresult Raw_context.t).
  
  Parameter remove_amount :
    Raw_context.t -> Contract_repr.t -> Tez_repr.t ->
    Lwt.t (Error_monad.tzresult Raw_context.t).
End Contract.

Parameter delegate_pubkey :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult (|Signature.Public_key|).(S.SPublic_key.t)).

Parameter get_rolls :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult (list Roll_repr.t)).

Parameter get_change :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult Tez_repr.t).

Parameter update_tokens_per_roll :
  Raw_context.t -> Tez_repr.t -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter get_contract_delegate :
  Raw_context.t -> Contract_repr.t ->
  Lwt.t
    (Error_monad.tzresult
      (option (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))).

Script_expr_hash

  • OCaml size: 43 lines
  • Coq size: 103 lines (+139% compared to OCaml)
script_expr_hash.ml 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let script_expr_hash = "\013\044\064\027" (* expr(54) *)

module Blake2BModule =
  Blake2B.Make
    (Base58)
    (struct
      let name = "script_expr"

      let title = "A script expression ID"

      let b58check_prefix = script_expr_hash

      let size = None
    end)

include Blake2BModule

let () = Base58.check_encoded_prefix b58check_encoding "expr" 54
Script_expr_hash.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Definition script_expr_hash : string := "\r,@\027".

Definition Blake2BModule :=
  (Blake2B.Make
    (existT (fun _ => _) tt
      {|
        Blake2B.SRegister.register_encoding {_} := Base58.register_encoding
      |}))
    (let name := "script_expr" in
    let title := "A script expression ID" in
    let b58check_prefix := script_expr_hash in
    let size := None in
    existT (fun _ => _) tt
      {|
        Blake2B.PrefixedName.name := name;
        Blake2B.PrefixedName.title := title;
        Blake2B.PrefixedName.size := size;
        Blake2B.PrefixedName.b58check_prefix := b58check_prefix
      |}).

Definition t := (|Blake2BModule|).(S.HASH.t).

Definition name := (|Blake2BModule|).(S.HASH.name).

Definition title := (|Blake2BModule|).(S.HASH.title).

Definition pp := (|Blake2BModule|).(S.HASH.pp).

Definition pp_short := (|Blake2BModule|).(S.HASH.pp_short).

Definition op_eq := (|Blake2BModule|).(S.HASH.op_eq).

Definition op_ltgt := (|Blake2BModule|).(S.HASH.op_ltgt).

Definition op_lt := (|Blake2BModule|).(S.HASH.op_lt).

Definition op_lteq := (|Blake2BModule|).(S.HASH.op_lteq).

Definition op_gteq := (|Blake2BModule|).(S.HASH.op_gteq).

Definition op_gt := (|Blake2BModule|).(S.HASH.op_gt).

Definition compare := (|Blake2BModule|).(S.HASH.compare).

Definition equal := (|Blake2BModule|).(S.HASH.equal).

Definition max := (|Blake2BModule|).(S.HASH.max).

Definition min := (|Blake2BModule|).(S.HASH.min).

Definition hash_bytes := (|Blake2BModule|).(S.HASH.hash_bytes).

Definition hash_string := (|Blake2BModule|).(S.HASH.hash_string).

Definition zero := (|Blake2BModule|).(S.HASH.zero).

Definition size := (|Blake2BModule|).(S.HASH.size).

Definition to_bytes := (|Blake2BModule|).(S.HASH.to_bytes).

Definition of_bytes_opt := (|Blake2BModule|).(S.HASH.of_bytes_opt).

Definition of_bytes_exn := (|Blake2BModule|).(S.HASH.of_bytes_exn).

Definition to_b58check := (|Blake2BModule|).(S.HASH.to_b58check).

Definition to_short_b58check := (|Blake2BModule|).(S.HASH.to_short_b58check).

Definition of_b58check_exn := (|Blake2BModule|).(S.HASH.of_b58check_exn).

Definition of_b58check_opt := (|Blake2BModule|).(S.HASH.of_b58check_opt).

Definition b58check_encoding := (|Blake2BModule|).(S.HASH.b58check_encoding).

Definition encoding := (|Blake2BModule|).(S.HASH.encoding).

Definition rpc_arg := (|Blake2BModule|).(S.HASH.rpc_arg).

Definition to_path := (|Blake2BModule|).(S.HASH.to_path).

Definition of_path := (|Blake2BModule|).(S.HASH.of_path).

Definition of_path_exn := (|Blake2BModule|).(S.HASH.of_path_exn).

Definition prefix_path := (|Blake2BModule|).(S.HASH.prefix_path).

Definition path_length := (|Blake2BModule|).(S.HASH.path_length).

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Script_int_repr

  • OCaml size: 102 lines
  • Coq size: 105 lines (+2% compared to OCaml)
script_int_repr.ml 4 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type n = Natural_tag

type z = Integer_tag

type 't num = Z.t

let compare x y = Z.compare x y

let zero = Z.zero

let zero_n = Z.zero

let to_string x = Z.to_string x

let of_string s = try Some (Z.of_string s) with _ -> None

let to_int64 x = try Some (Z.to_int64 x) with _ -> None

let of_int64 n = Z.of_int64 n

let to_int x = try Some (Z.to_int x) with _ -> None

let of_int n = Z.of_int n

let of_zint x = x

let to_zint x = x

let add x y = Z.add x y

let sub x y = Z.sub x y

let mul x y = Z.mul x y

let ediv x y =
  try
    let (q, r) = Z.ediv_rem x y in
    Some (q, r)
  with _ -> None

let add_n = add

let mul_n = mul

let ediv_n = ediv

let abs x = Z.abs x

let is_nat x = if Compare.Z.(x < Z.zero) then None else Some x

let neg x = Z.neg x

let int x = x

let shift_left x y =
  if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then None
  else
    let y = Z.to_int y in
    Some (Z.shift_left x y)

let shift_right x y =
  if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then None
  else
    let y = Z.to_int y in
    Some (Z.shift_right x y)

let shift_left_n = shift_left

let shift_right_n = shift_right

let logor x y = Z.logor x y

let logxor x y = Z.logxor x y

let logand x y = Z.logand x y

let lognot x = Z.lognot x
Script_int_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Inductive n : Set :=
| Natural_tag : n.

Inductive z : Set :=
| Integer_tag : z.

Definition num (t : Set) := Z.t.

Definition compare (x : Z.t) (y : Z.t) : Z := Z.compare x y.

Definition zero : Z.t := Z.zero.

Definition zero_n : Z.t := Z.zero.

Definition to_string (x : Z.t) : string := Z.to_string x.

Definition of_string (s : string) : option Z.t :=
  (* ❌ Try-with are not handled *)
  try (Some (Z.of_string s)).

Definition to_int64 (x : Z.t) : option int64 :=
  (* ❌ Try-with are not handled *)
  try (Some (Z.to_int64 x)).

Definition of_int64 (n : int64) : Z.t := Z.of_int64 n.

Definition to_int (x : Z.t) : option Z :=
  (* ❌ Try-with are not handled *)
  try (Some (Z.to_int x)).

Definition of_int (n : Z) : Z.t := Z.of_int n.

Definition of_zint {A : Set} (x : A) : A := x.

Definition to_zint {A : Set} (x : A) : A := x.

Definition add (x : Z.t) (y : Z.t) : Z.t := Z.add x y.

Definition sub (x : Z.t) (y : Z.t) : Z.t := Z.sub x y.

Definition mul (x : Z.t) (y : Z.t) : Z.t := Z.mul x y.

Definition ediv (x : Z.t) (y : Z.t) : option (Z.t * Z.t) :=
  (* ❌ Try-with are not handled *)
  try
    (let '(q, r) := Z.ediv_rem x y in
    Some (q, r)).

Definition add_n : Z.t -> Z.t -> Z.t := add.

Definition mul_n : Z.t -> Z.t -> Z.t := mul.

Definition ediv_n : Z.t -> Z.t -> option (Z.t * Z.t) := ediv.

Definition abs (x : Z.t) : Z.t := Z.abs x.

Definition is_nat (x : (|Compare.Z|).(Compare.S.t))
  : option (|Compare.Z|).(Compare.S.t) :=
  if (|Compare.Z|).(Compare.S.op_lt) x Z.zero then
    None
  else
    Some x.

Definition neg (x : Z.t) : Z.t := Z.neg x.

Definition int {A : Set} (x : A) : A := x.

Definition shift_left (x : Z.t) (y : Z.t) : option Z.t :=
  if (|Compare.Int|).(Compare.S.op_gt) (Z.compare y (Z.of_int 256)) 0 then
    None
  else
    let y := Z.to_int y in
    Some (Z.shift_left x y).

Definition shift_right (x : Z.t) (y : Z.t) : option Z.t :=
  if (|Compare.Int|).(Compare.S.op_gt) (Z.compare y (Z.of_int 256)) 0 then
    None
  else
    let y := Z.to_int y in
    Some (Z.shift_right x y).

Definition shift_left_n : Z.t -> Z.t -> option Z.t := shift_left.

Definition shift_right_n : Z.t -> Z.t -> option Z.t := shift_right.

Definition logor (x : Z.t) (y : Z.t) : Z.t := Z.logor x y.

Definition logxor (x : Z.t) (y : Z.t) : Z.t := Z.logxor x y.

Definition logand (x : Z.t) (y : Z.t) : Z.t := Z.logand x y.

Definition lognot (x : Z.t) : Z.t := Z.lognot x.

Script_int_repr_mli

  • OCaml size: 143 lines
  • Coq size: 80 lines (-45% compared to OCaml)
script_int_repr.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** The types for arbitraty precision integers in Michelson.
    The type variable ['t] is always [n] or [z],
    [n num] and [z num] are incompatible.

    This is internally a [Z.t].
    This module mostly adds signedness preservation guarantees. *)
type 't num

(** Flag for natural numbers. *)
type n = Natural_tag

(** Flag for relative numbers. *)
type z = Integer_tag

(** Natural zero. *)
val zero_n : n num

(** Relative zero. *)
val zero : z num

(** Compare two numbers as if they were *)
val compare : 'a num -> 'a num -> int

(** Conversion to an OCaml [string] in decimal notation. *)
val to_string : _ num -> string

(** Conversion from an OCaml [string].
    Returns [None] in case of an invalid notation.
    Supports [+] and [-] sign modifiers, and [0x], [0o] and [0b] base modifiers. *)
val of_string : string -> z num option

(** Conversion to an OCaml [int64], returns [None] on overflow. *)
val to_int64 : _ num -> int64 option

(** Conversion from an OCaml [int]. *)
val of_int64 : int64 -> z num

(** Conversion to an OCaml [int], returns [None] on overflow. *)
val to_int : _ num -> int option

(** Conversion from an OCaml [int64]. *)
val of_int : int -> z num

(** Conversion from a Zarith integer ([Z.t]). *)
val of_zint : Z.t -> z num

(** Conversion to a Zarith integer ([Z.t]). *)
val to_zint : 'a num -> Z.t

(** Addition between naturals. *)
val add_n : n num -> n num -> n num

(** Multiplication between naturals. *)
val mul_n : n num -> n num -> n num

(** Euclidean division between naturals.
    [ediv_n n d] returns [None] if divisor is zero,
    or [Some (q, r)] where [n = d * q + r] and [[0 <= r < d]] otherwise. *)
val ediv_n : n num -> n num -> (n num * n num) option

(** Sign agnostic addition.
    Use {!add_n} when working with naturals to preserve the sign. *)
val add : _ num -> _ num -> z num

(** Sign agnostic subtraction.
    Use {!sub_n} when working with naturals to preserve the sign. *)
val sub : _ num -> _ num -> z num

(** Sign agnostic multiplication.
    Use {!mul_n} when working with naturals to preserve the sign. *)
val mul : _ num -> _ num -> z num

(** Sign agnostic euclidean division.
    [ediv n d] returns [None] if divisor is zero,
    or [Some (q, r)] where [n = d * q + r] and [[0 <= r < |d|]] otherwise.
    Use {!ediv_n} when working with naturals to preserve the sign. *)
val ediv : _ num -> _ num -> (z num * n num) option

(** Compute the absolute value of a relative, turning it into a natural. *)
val abs : z num -> n num

(** Partial identity over [N]. *)
val is_nat : z num -> n num option

(** Negates a number. *)
val neg : _ num -> z num

(** Turns a natural into a relative, not changing its value. *)
val int : n num -> z num

(** Reverses each bit in the representation of the number.
    Also applies to the sign. *)
val lognot : _ num -> z num

(** Shifts the natural to the left of a number of bits between 0 and 256.
    Returns [None] if the amount is too high. *)
val shift_left_n : n num -> n num -> n num option

(** Shifts the natural to the right of a number of bits between 0 and 256.
    Returns [None] if the amount is too high. *)
val shift_right_n : n num -> n num -> n num option

(** Shifts the number to the left of a number of bits between 0 and 256.
    Returns [None] if the amount is too high. *)
val shift_left : 'a num -> n num -> 'a num option

(** Shifts the number to the right of a number of bits between 0 and 256.
    Returns [None] if the amount is too high. *)
val shift_right : 'a num -> n num -> 'a num option

(** Applies a boolean or operation to each bit. *)
val logor : 'a num -> 'a num -> 'a num

(** Applies a boolean and operation to each bit. *)
val logand : _ num -> n num -> n num

(** Applies a boolean xor operation to each bit. *)
val logxor : n num -> n num -> n num
Script_int_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Parameter num : forall (t : Set), Set.

Inductive n : Set :=
| Natural_tag : n.

Inductive z : Set :=
| Integer_tag : z.

Parameter zero_n : num n.

Parameter zero : num z.

Parameter compare : forall {a : Set}, num a -> num a -> Z.

Parameter to_string : forall {A : Set}, num A -> string.

Parameter of_string : string -> option (num z).

Parameter to_int64 : forall {A : Set}, num A -> option int64.

Parameter of_int64 : int64 -> num z.

Parameter to_int : forall {A : Set}, num A -> option Z.

Parameter of_int : Z -> num z.

Parameter of_zint : Z.t -> num z.

Parameter to_zint : forall {a : Set}, num a -> Z.t.

Parameter add_n : num n -> num n -> num n.

Parameter mul_n : num n -> num n -> num n.

Parameter ediv_n : num n -> num n -> option (num n * num n).

Parameter add : forall {A B : Set}, num A -> num B -> num z.

Parameter sub : forall {A B : Set}, num A -> num B -> num z.

Parameter mul : forall {A B : Set}, num A -> num B -> num z.

Parameter ediv : forall {A B : Set}, num A -> num B -> option (num z * num n).

Parameter abs : num z -> num n.

Parameter is_nat : num z -> option (num n).

Parameter neg : forall {A : Set}, num A -> num z.

Parameter int : num n -> num z.

Parameter lognot : forall {A : Set}, num A -> num z.

Parameter shift_left_n : num n -> num n -> option (num n).

Parameter shift_right_n : num n -> num n -> option (num n).

Parameter shift_left : forall {a : Set}, num a -> num n -> option (num a).

Parameter shift_right : forall {a : Set}, num a -> num n -> option (num a).

Parameter logor : forall {a : Set}, num a -> num a -> num a.

Parameter logand : forall {A : Set}, num A -> num n -> num n.

Parameter logxor : num n -> num n -> num n.

Script_interpreter

  • OCaml size: 1520 lines
  • Coq size: 1956 lines (+28% compared to OCaml)
script_interpreter.ml 30 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Script
open Script_typed_ir
open Script_ir_translator

(* ---- Run-time errors -----------------------------------------------------*)

type execution_trace =
  (Script.location * Gas.t * (Script.expr * string option) list) list

type error +=
  | Reject of Script.location * Script.expr * execution_trace option

type error += Overflow of Script.location * execution_trace option

type error += Runtime_contract_error : Contract.t * Script.expr -> error

type error += Bad_contract_parameter of Contract.t (* `Permanent *)

type error += Cannot_serialize_log

type error += Cannot_serialize_failure

type error += Cannot_serialize_storage

let () =
  let open Data_encoding in
  let trace_encoding =
    list
    @@ obj3
         (req "location" Script.location_encoding)
         (req "gas" Gas.encoding)
         (req
            "stack"
            (list (obj2 (req "item" Script.expr_encoding) (opt "annot" string))))
  in
  (* Reject *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.script_rejected"
    ~title:"Script failed"
    ~description:"A FAILWITH instruction was reached"
    (obj3
       (req "location" Script.location_encoding)
       (req "with" Script.expr_encoding)
       (opt "trace" trace_encoding))
    (function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None)
    (fun (loc, v, trace) -> Reject (loc, v, trace)) ;
  (* Overflow *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.script_overflow"
    ~title:"Script failed (overflow error)"
    ~description:
      "A FAIL instruction was reached due to the detection of an overflow"
    (obj2
       (req "location" Script.location_encoding)
       (opt "trace" trace_encoding))
    (function Overflow (loc, trace) -> Some (loc, trace) | _ -> None)
    (fun (loc, trace) -> Overflow (loc, trace)) ;
  (* Runtime contract error *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.runtime_error"
    ~title:"Script runtime error"
    ~description:"Toplevel error for all runtime script errors"
    (obj2
       (req "contract_handle" Contract.encoding)
       (req "contract_code" Script.expr_encoding))
    (function
      | Runtime_contract_error (contract, expr) ->
          Some (contract, expr)
      | _ ->
          None)
    (fun (contract, expr) -> Runtime_contract_error (contract, expr)) ;
  (* Bad contract parameter *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.bad_contract_parameter"
    ~title:"Contract supplied an invalid parameter"
    ~description:
      "Either no parameter was supplied to a contract with a non-unit \
       parameter type, a non-unit parameter was passed to an account, or a \
       parameter was supplied of the wrong type"
    Data_encoding.(obj1 (req "contract" Contract.encoding))
    (function Bad_contract_parameter c -> Some c | _ -> None)
    (fun c -> Bad_contract_parameter c) ;
  (* Cannot serialize log *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.cannot_serialize_log"
    ~title:"Not enough gas to serialize execution trace"
    ~description:
      "Execution trace with stacks was to big to be serialized with the \
       provided gas"
    Data_encoding.empty
    (function Cannot_serialize_log -> Some () | _ -> None)
    (fun () -> Cannot_serialize_log) ;
  (* Cannot serialize failure *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.cannot_serialize_failure"
    ~title:"Not enough gas to serialize argument of FAILWITH"
    ~description:
      "Argument of FAILWITH was too big to be serialized with the provided gas"
    Data_encoding.empty
    (function Cannot_serialize_failure -> Some () | _ -> None)
    (fun () -> Cannot_serialize_failure) ;
  (* Cannot serialize storage *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.cannot_serialize_storage"
    ~title:"Not enough gas to serialize execution storage"
    ~description:
      "The returned storage was too big to be serialized with the provided gas"
    Data_encoding.empty
    (function Cannot_serialize_storage -> Some () | _ -> None)
    (fun () -> Cannot_serialize_storage)

(* ---- interpreter ---------------------------------------------------------*)

type 'tys stack =
  | Item : 'ty * 'rest stack -> ('ty * 'rest) stack
  | Empty : end_of_stack stack

let unparse_stack ctxt (stack, stack_ty) =
  (* We drop the gas limit as this function is only used for debugging/errors. *)
  let ctxt = Gas.set_unlimited ctxt in
  let rec unparse_stack :
      type a.
      a stack * a stack_ty -> (Script.expr * string option) list tzresult Lwt.t
      = function
    | (Empty, Empty_t) ->
        return_nil
    | (Item (v, rest), Item_t (ty, rest_ty, annot)) ->
        unparse_data ctxt Readable ty v
        >>=? fun (data, _ctxt) ->
        unparse_stack (rest, rest_ty)
        >>=? fun rest ->
        let annot =
          match Script_ir_annot.unparse_var_annot annot with
          | [] ->
              None
          | [a] ->
              Some a
          | _ ->
              assert false
        in
        let data = Micheline.strip_locations data in
        return ((data, annot) :: rest)
  in
  unparse_stack (stack, stack_ty)

module Interp_costs = Michelson_v1_gas.Cost_of.Interpreter

let rec interp_stack_prefix_preserving_operation :
    type fbef bef faft aft result.
    (fbef stack -> (faft stack * result) tzresult Lwt.t) ->
    (fbef, faft, bef, aft) stack_prefix_preservation_witness ->
    bef stack ->
    (aft stack * result) tzresult Lwt.t =
 fun f n stk ->
  match (n, stk) with
  | ( Prefix
        (Prefix
          (Prefix
            (Prefix
              (Prefix
                (Prefix
                  (Prefix
                    (Prefix
                      (Prefix
                        (Prefix
                          (Prefix
                            (Prefix (Prefix (Prefix (Prefix (Prefix n))))))))))))))),
      Item
        ( v0,
          Item
            ( v1,
              Item
                ( v2,
                  Item
                    ( v3,
                      Item
                        ( v4,
                          Item
                            ( v5,
                              Item
                                ( v6,
                                  Item
                                    ( v7,
                                      Item
                                        ( v8,
                                          Item
                                            ( v9,
                                              Item
                                                ( va,
                                                  Item
                                                    ( vb,
                                                      Item
                                                        ( vc,
                                                          Item
                                                            ( vd,
                                                              Item
                                                                ( ve,
                                                                  Item
                                                                    (vf, rest)
                                                                ) ) ) ) ) ) )
                                    ) ) ) ) ) ) ) ) ) ->
      interp_stack_prefix_preserving_operation f n rest
      >>=? fun (rest', result) ->
      return
        ( Item
            ( v0,
              Item
                ( v1,
                  Item
                    ( v2,
                      Item
                        ( v3,
                          Item
                            ( v4,
                              Item
                                ( v5,
                                  Item
                                    ( v6,
                                      Item
                                        ( v7,
                                          Item
                                            ( v8,
                                              Item
                                                ( v9,
                                                  Item
                                                    ( va,
                                                      Item
                                                        ( vb,
                                                          Item
                                                            ( vc,
                                                              Item
                                                                ( vd,
                                                                  Item
                                                                    ( ve,
                                                                      Item
                                                                        ( vf,
                                                                          rest'
                                                                        ) ) )
                                                            ) ) ) ) ) ) ) ) )
                        ) ) ) ),
          result )
  | ( Prefix (Prefix (Prefix (Prefix n))),
      Item (v0, Item (v1, Item (v2, Item (v3, rest)))) ) ->
      interp_stack_prefix_preserving_operation f n rest
      >>=? fun (rest', result) ->
      return (Item (v0, Item (v1, Item (v2, Item (v3, rest')))), result)
  | (Prefix n, Item (v, rest)) ->
      interp_stack_prefix_preserving_operation f n rest
      >>=? fun (rest', result) -> return (Item (v, rest'), result)
  | (Rest, v) ->
      f v

type step_constants = {
  source : Contract.t;
  payer : Contract.t;
  self : Contract.t;
  amount : Tez.t;
  chain_id : Chain_id.t;
}

let rec step :
    type b a.
    ?log:execution_trace ref ->
    context ->
    step_constants ->
    (b, a) descr ->
    b stack ->
    (a stack * context) tzresult Lwt.t =
 fun ?log ctxt step_constants ({instr; loc; _} as descr) stack ->
  Lwt.return (Gas.consume ctxt Interp_costs.cycle)
  >>=? fun ctxt ->
  let logged_return :
      type a b.
      (b, a) descr -> a stack * context -> (a stack * context) tzresult Lwt.t =
   fun descr (ret, ctxt) ->
    match log with
    | None ->
        return (ret, ctxt)
    | Some log ->
        trace Cannot_serialize_log (unparse_stack ctxt (ret, descr.aft))
        >>=? fun stack ->
        log := (descr.loc, Gas.level ctxt, stack) :: !log ;
        return (ret, ctxt)
  in
  let get_log (log : execution_trace ref option) =
    Option.map ~f:(fun l -> List.rev !l) log
  in
  let consume_gas_terop :
      type ret arg1 arg2 arg3 rest.
      (_ * (_ * (_ * rest)), ret * rest) descr ->
      (arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3 ->
      (arg1 -> arg2 -> arg3 -> Gas.cost) ->
      rest stack ->
      ((ret * rest) stack * context) tzresult Lwt.t =
   fun descr (op, x1, x2, x3) cost_func rest ->
    Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3))
    >>=? fun ctxt -> logged_return descr (Item (op x1 x2 x3, rest), ctxt)
  in
  let consume_gas_binop :
      type ret arg1 arg2 rest.
      (_ * (_ * rest), ret * rest) descr ->
      (arg1 -> arg2 -> ret) * arg1 * arg2 ->
      (arg1 -> arg2 -> Gas.cost) ->
      rest stack ->
      context ->
      ((ret * rest) stack * context) tzresult Lwt.t =
   fun descr (op, x1, x2) cost_func rest ctxt ->
    Lwt.return (Gas.consume ctxt (cost_func x1 x2))
    >>=? fun ctxt -> logged_return descr (Item (op x1 x2, rest), ctxt)
  in
  let consume_gas_unop :
      type ret arg rest.
      (_ * rest, ret * rest) descr ->
      (arg -> ret) * arg ->
      (arg -> Gas.cost) ->
      rest stack ->
      context ->
      ((ret * rest) stack * context) tzresult Lwt.t =
   fun descr (op, arg) cost_func rest ctxt ->
    Lwt.return (Gas.consume ctxt (cost_func arg))
    >>=? fun ctxt -> logged_return descr (Item (op arg, rest), ctxt)
  in
  let logged_return : a stack * context -> (a stack * context) tzresult Lwt.t =
    logged_return descr
  in
  match (instr, stack) with
  (* stack ops *)
  | (Drop, Item (_, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.stack_op)
      >>=? fun ctxt -> logged_return (rest, ctxt)
  | (Dup, Item (v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.stack_op)
      >>=? fun ctxt -> logged_return (Item (v, Item (v, rest)), ctxt)
  | (Swap, Item (vi, Item (vo, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.stack_op)
      >>=? fun ctxt -> logged_return (Item (vo, Item (vi, rest)), ctxt)
  | (Const v, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.push)
      >>=? fun ctxt -> logged_return (Item (v, rest), ctxt)
  (* options *)
  | (Cons_some, Item (v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.wrap)
      >>=? fun ctxt -> logged_return (Item (Some v, rest), ctxt)
  | (Cons_none _, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data)
      >>=? fun ctxt -> logged_return (Item (None, rest), ctxt)
  | (If_none (bt, _), Item (None, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bt rest
  | (If_none (_, bf), Item (Some v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bf (Item (v, rest))
  (* pairs *)
  | (Cons_pair, Item (a, Item (b, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.pair)
      >>=? fun ctxt -> logged_return (Item ((a, b), rest), ctxt)
  (* Peephole optimization for UNPAIR *)
  | ( Seq
        ( {instr = Dup; _},
          { instr =
              Seq
                ( {instr = Car; _},
                  { instr = Seq ({instr = Dip {instr = Cdr}}, {instr = Nop; _});
                    _ } );
            _ } ),
      Item ((a, b), rest) ) ->
      Lwt.return (Gas.consume ctxt Interp_costs.pair_access)
      >>=? fun ctxt -> logged_return (Item (a, Item (b, rest)), ctxt)
  | (Car, Item ((a, _), rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.pair_access)
      >>=? fun ctxt -> logged_return (Item (a, rest), ctxt)
  | (Cdr, Item ((_, b), rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.pair_access)
      >>=? fun ctxt -> logged_return (Item (b, rest), ctxt)
  (* unions *)
  | (Left, Item (v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.wrap)
      >>=? fun ctxt -> logged_return (Item (L v, rest), ctxt)
  | (Right, Item (v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.wrap)
      >>=? fun ctxt -> logged_return (Item (R v, rest), ctxt)
  | (If_left (bt, _), Item (L v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bt (Item (v, rest))
  | (If_left (_, bf), Item (R v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bf (Item (v, rest))
  (* lists *)
  | (Cons_list, Item (hd, Item (tl, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.cons)
      >>=? fun ctxt -> logged_return (Item (hd :: tl, rest), ctxt)
  | (Nil, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data)
      >>=? fun ctxt -> logged_return (Item ([], rest), ctxt)
  | (If_cons (_, bf), Item ([], rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bf rest
  | (If_cons (bt, _), Item (hd :: tl, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt ->
      step ?log ctxt step_constants bt (Item (hd, Item (tl, rest)))
  | (List_map body, Item (l, rest)) ->
      let rec loop rest ctxt l acc =
        Lwt.return (Gas.consume ctxt Interp_costs.loop_map)
        >>=? fun ctxt ->
        match l with
        | [] ->
            return (Item (List.rev acc, rest), ctxt)
        | hd :: tl ->
            step ?log ctxt step_constants body (Item (hd, rest))
            >>=? fun (Item (hd, rest), ctxt) -> loop rest ctxt tl (hd :: acc)
      in
      loop rest ctxt l [] >>=? fun (res, ctxt) -> logged_return (res, ctxt)
  | (List_size, Item (list, rest)) ->
      Lwt.return
        (List.fold_left
           (fun acc _ ->
             acc
             >>? fun (size, ctxt) ->
             Gas.consume ctxt Interp_costs.loop_size
             >>? fun ctxt -> ok (size + 1 (* FIXME: overflow *), ctxt))
           (ok (0, ctxt))
           list)
      >>=? fun (len, ctxt) ->
      logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt)
  | (List_iter body, Item (l, init)) ->
      let rec loop ctxt l stack =
        Lwt.return (Gas.consume ctxt Interp_costs.loop_iter)
        >>=? fun ctxt ->
        match l with
        | [] ->
            return (stack, ctxt)
        | hd :: tl ->
            step ?log ctxt step_constants body (Item (hd, stack))
            >>=? fun (stack, ctxt) -> loop ctxt tl stack
      in
      loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt)
  (* sets *)
  | (Empty_set t, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.empty_set)
      >>=? fun ctxt -> logged_return (Item (empty_set t, rest), ctxt)
  | (Set_iter body, Item (set, init)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set))
      >>=? fun ctxt ->
      let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in
      let rec loop ctxt l stack =
        Lwt.return (Gas.consume ctxt Interp_costs.loop_iter)
        >>=? fun ctxt ->
        match l with
        | [] ->
            return (stack, ctxt)
        | hd :: tl ->
            step ?log ctxt step_constants body (Item (hd, stack))
            >>=? fun (stack, ctxt) -> loop ctxt tl stack
      in
      loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt)
  | (Set_mem, Item (v, Item (set, rest))) ->
      consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt
  | (Set_update, Item (v, Item (presence, Item (set, rest)))) ->
      consume_gas_terop
        descr
        (set_update, v, presence, set)
        Interp_costs.set_update
        rest
  | (Set_size, Item (set, rest)) ->
      consume_gas_unop
        descr
        (set_size, set)
        (fun _ -> Interp_costs.set_size)
        rest
        ctxt
  (* maps *)
  | (Empty_map (t, _), rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.empty_map)
      >>=? fun ctxt -> logged_return (Item (empty_map t, rest), ctxt)
  | (Map_map body, Item (map, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map))
      >>=? fun ctxt ->
      let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
      let rec loop rest ctxt l acc =
        Lwt.return (Gas.consume ctxt Interp_costs.loop_map)
        >>=? fun ctxt ->
        match l with
        | [] ->
            return (acc, ctxt)
        | ((k, _) as hd) :: tl ->
            step ?log ctxt step_constants body (Item (hd, rest))
            >>=? fun (Item (hd, rest), ctxt) ->
            loop rest ctxt tl (map_update k (Some hd) acc)
      in
      loop rest ctxt l (empty_map (map_key_ty map))
      >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
  | (Map_iter body, Item (map, init)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map))
      >>=? fun ctxt ->
      let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
      let rec loop ctxt l stack =
        Lwt.return (Gas.consume ctxt Interp_costs.loop_iter)
        >>=? fun ctxt ->
        match l with
        | [] ->
            return (stack, ctxt)
        | hd :: tl ->
            step ?log ctxt step_constants body (Item (hd, stack))
            >>=? fun (stack, ctxt) -> loop ctxt tl stack
      in
      loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt)
  | (Map_mem, Item (v, Item (map, rest))) ->
      consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt
  | (Map_get, Item (v, Item (map, rest))) ->
      consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt
  | (Map_update, Item (k, Item (v, Item (map, rest)))) ->
      consume_gas_terop
        descr
        (map_update, k, v, map)
        Interp_costs.map_update
        rest
  | (Map_size, Item (map, rest)) ->
      consume_gas_unop
        descr
        (map_size, map)
        (fun _ -> Interp_costs.map_size)
        rest
        ctxt
  (* Big map operations *)
  | (Empty_big_map (tk, tv), rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.empty_map)
      >>=? fun ctxt ->
      logged_return
        (Item (Script_ir_translator.empty_big_map tk tv, rest), ctxt)
  | (Big_map_mem, Item (key, Item (map, rest))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.map_mem key map.diff))
      >>=? fun ctxt ->
      Script_ir_translator.big_map_mem ctxt key map
      >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
  | (Big_map_get, Item (key, Item (map, rest))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.map_get key map.diff))
      >>=? fun ctxt ->
      Script_ir_translator.big_map_get ctxt key map
      >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
  | (Big_map_update, Item (key, Item (maybe_value, Item (map, rest)))) ->
      consume_gas_terop
        descr
        (Script_ir_translator.big_map_update, key, maybe_value, map)
        (fun k v m -> Interp_costs.map_update k (Some v) m.diff)
        rest
  (* timestamp operations *)
  | (Add_seconds_to_timestamp, Item (n, Item (t, rest))) ->
      consume_gas_binop
        descr
        (Script_timestamp.add_delta, t, n)
        Interp_costs.add_timestamp
        rest
        ctxt
  | (Add_timestamp_to_seconds, Item (t, Item (n, rest))) ->
      consume_gas_binop
        descr
        (Script_timestamp.add_delta, t, n)
        Interp_costs.add_timestamp
        rest
        ctxt
  | (Sub_timestamp_seconds, Item (t, Item (s, rest))) ->
      consume_gas_binop
        descr
        (Script_timestamp.sub_delta, t, s)
        Interp_costs.sub_timestamp
        rest
        ctxt
  | (Diff_timestamps, Item (t1, Item (t2, rest))) ->
      consume_gas_binop
        descr
        (Script_timestamp.diff, t1, t2)
        Interp_costs.diff_timestamps
        rest
        ctxt
  (* string operations *)
  | (Concat_string_pair, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y]))
      >>=? fun ctxt ->
      let s = String.concat "" [x; y] in
      logged_return (Item (s, rest), ctxt)
  | (Concat_string, Item (ss, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss))
      >>=? fun ctxt ->
      let s = String.concat "" ss in
      logged_return (Item (s, rest), ctxt)
  | (Slice_string, Item (offset, Item (length, Item (s, rest)))) ->
      let s_length = Z.of_int (String.length s) in
      let offset = Script_int.to_zint offset in
      let length = Script_int.to_zint length in
      if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then
        Lwt.return
          (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length)))
        >>=? fun ctxt ->
        logged_return
          ( Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest),
            ctxt )
      else
        Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0))
        >>=? fun ctxt -> logged_return (Item (None, rest), ctxt)
  | (String_size, Item (s, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.push)
      >>=? fun ctxt ->
      logged_return
        (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt)
  (* bytes operations *)
  | (Concat_bytes_pair, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y]))
      >>=? fun ctxt ->
      let s = MBytes.concat "" [x; y] in
      logged_return (Item (s, rest), ctxt)
  | (Concat_bytes, Item (ss, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss))
      >>=? fun ctxt ->
      let s = MBytes.concat "" ss in
      logged_return (Item (s, rest), ctxt)
  | (Slice_bytes, Item (offset, Item (length, Item (s, rest)))) ->
      let s_length = Z.of_int (MBytes.length s) in
      let offset = Script_int.to_zint offset in
      let length = Script_int.to_zint length in
      if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then
        Lwt.return
          (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length)))
        >>=? fun ctxt ->
        logged_return
          ( Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest),
            ctxt )
      else
        Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0))
        >>=? fun ctxt -> logged_return (Item (None, rest), ctxt)
  | (Bytes_size, Item (s, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.push)
      >>=? fun ctxt ->
      logged_return
        (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt)
  (* currency operations *)
  | (Add_tez, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.int64_op)
      >>=? fun ctxt ->
      Lwt.return Tez.(x +? y)
      >>=? fun res -> logged_return (Item (res, rest), ctxt)
  | (Sub_tez, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.int64_op)
      >>=? fun ctxt ->
      Lwt.return Tez.(x -? y)
      >>=? fun res -> logged_return (Item (res, rest), ctxt)
  | (Mul_teznat, Item (x, Item (y, rest))) -> (
      Lwt.return (Gas.consume ctxt Interp_costs.int64_op)
      >>=? fun ctxt ->
      Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64)
      >>=? fun ctxt ->
      match Script_int.to_int64 y with
      | None ->
          fail (Overflow (loc, get_log log))
      | Some y ->
          Lwt.return Tez.(x *? y)
          >>=? fun res -> logged_return (Item (res, rest), ctxt) )
  | (Mul_nattez, Item (y, Item (x, rest))) -> (
      Lwt.return (Gas.consume ctxt Interp_costs.int64_op)
      >>=? fun ctxt ->
      Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64)
      >>=? fun ctxt ->
      match Script_int.to_int64 y with
      | None ->
          fail (Overflow (loc, get_log log))
      | Some y ->
          Lwt.return Tez.(x *? y)
          >>=? fun res -> logged_return (Item (res, rest), ctxt) )
  (* boolean operations *)
  | (Or, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (( || ), x, y) Interp_costs.bool_binop rest ctxt
  | (And, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (( && ), x, y) Interp_costs.bool_binop rest ctxt
  | (Xor, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Compare.Bool.( <> ), x, y)
        Interp_costs.bool_binop
        rest
        ctxt
  | (Not, Item (x, rest)) ->
      consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt
  (* integer operations *)
  | (Is_nat, Item (x, rest)) ->
      consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt
  | (Abs_int, Item (x, rest)) ->
      consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt
  | (Int_nat, Item (x, rest)) ->
      consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt
  | (Neg_int, Item (x, rest)) ->
      consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
  | (Neg_nat, Item (x, rest)) ->
      consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
  | (Add_intint, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
  | (Add_intnat, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
  | (Add_natint, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
  | (Add_natnat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.add_n, x, y)
        Interp_costs.add
        rest
        ctxt
  | (Sub_int, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt
  | (Mul_intint, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
  | (Mul_intnat, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
  | (Mul_natint, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
  | (Mul_natnat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.mul_n, x, y)
        Interp_costs.mul
        rest
        ctxt
  | (Ediv_teznat, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z)
      >>=? fun ctxt ->
      let x = Script_int.of_int64 (Tez.to_mutez x) in
      consume_gas_binop
        descr
        ( (fun x y ->
            match Script_int.ediv x y with
            | None ->
                None
            | Some (q, r) -> (
              match (Script_int.to_int64 q, Script_int.to_int64 r) with
              | (Some q, Some r) -> (
                match (Tez.of_mutez q, Tez.of_mutez r) with
                | (Some q, Some r) ->
                    Some (q, r)
                (* Cannot overflow *)
                | _ ->
                    assert false )
              (* Cannot overflow *)
              | _ ->
                  assert false )),
          x,
          y )
        Interp_costs.div
        rest
        ctxt
  | (Ediv_tez, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z)
      >>=? fun ctxt ->
      Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z)
      >>=? fun ctxt ->
      let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in
      let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in
      consume_gas_binop
        descr
        ( (fun x y ->
            match Script_int.ediv_n x y with
            | None ->
                None
            | Some (q, r) -> (
              match Script_int.to_int64 r with
              | None ->
                  assert false (* Cannot overflow *)
              | Some r -> (
                match Tez.of_mutez r with
                | None ->
                    assert false (* Cannot overflow *)
                | Some r ->
                    Some (q, r) ) )),
          x,
          y )
        Interp_costs.div
        rest
        ctxt
  | (Ediv_intint, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.ediv, x, y)
        Interp_costs.div
        rest
        ctxt
  | (Ediv_intnat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.ediv, x, y)
        Interp_costs.div
        rest
        ctxt
  | (Ediv_natint, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.ediv, x, y)
        Interp_costs.div
        rest
        ctxt
  | (Ediv_natnat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.ediv_n, x, y)
        Interp_costs.div
        rest
        ctxt
  | (Lsl_nat, Item (x, Item (y, rest))) -> (
      Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y))
      >>=? fun ctxt ->
      match Script_int.shift_left_n x y with
      | None ->
          fail (Overflow (loc, get_log log))
      | Some x ->
          logged_return (Item (x, rest), ctxt) )
  | (Lsr_nat, Item (x, Item (y, rest))) -> (
      Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y))
      >>=? fun ctxt ->
      match Script_int.shift_right_n x y with
      | None ->
          fail (Overflow (loc, get_log log))
      | Some r ->
          logged_return (Item (r, rest), ctxt) )
  | (Or_nat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.logor, x, y)
        Interp_costs.logor
        rest
        ctxt
  | (And_nat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.logand, x, y)
        Interp_costs.logand
        rest
        ctxt
  | (And_int_nat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.logand, x, y)
        Interp_costs.logand
        rest
        ctxt
  | (Xor_nat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.logxor, x, y)
        Interp_costs.logxor
        rest
        ctxt
  | (Not_int, Item (x, rest)) ->
      consume_gas_unop
        descr
        (Script_int.lognot, x)
        Interp_costs.lognot
        rest
        ctxt
  | (Not_nat, Item (x, rest)) ->
      consume_gas_unop
        descr
        (Script_int.lognot, x)
        Interp_costs.lognot
        rest
        ctxt
  (* control *)
  | (Seq (hd, tl), stack) ->
      step ?log ctxt step_constants hd stack
      >>=? fun (trans, ctxt) -> step ?log ctxt step_constants tl trans
  | (If (bt, _), Item (true, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bt rest
  | (If (_, bf), Item (false, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bf rest
  | (Loop body, Item (true, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle)
      >>=? fun ctxt ->
      step ?log ctxt step_constants body rest
      >>=? fun (trans, ctxt) -> step ?log ctxt step_constants descr trans
  | (Loop _, Item (false, rest)) ->
      logged_return (rest, ctxt)
  | (Loop_left body, Item (L v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle)
      >>=? fun ctxt ->
      step ?log ctxt step_constants body (Item (v, rest))
      >>=? fun (trans, ctxt) -> step ?log ctxt step_constants descr trans
  | (Loop_left _, Item (R v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle)
      >>=? fun ctxt -> logged_return (Item (v, rest), ctxt)
  | (Dip b, Item (ign, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.stack_op)
      >>=? fun ctxt ->
      step ?log ctxt step_constants b rest
      >>=? fun (res, ctxt) -> logged_return (Item (ign, res), ctxt)
  | (Exec, Item (arg, Item (lam, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.exec)
      >>=? fun ctxt ->
      interp ?log ctxt step_constants lam arg
      >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
  | (Apply capture_ty, Item (capture, Item (lam, rest))) -> (
      Lwt.return (Gas.consume ctxt Interp_costs.apply)
      >>=? fun ctxt ->
      let (Lam (descr, expr)) = lam in
      let (Item_t (full_arg_ty, _, _)) = descr.bef in
      unparse_data ctxt Optimized capture_ty capture
      >>=? fun (const_expr, ctxt) ->
      unparse_ty ctxt capture_ty
      >>=? fun (ty_expr, ctxt) ->
      match full_arg_ty with
      | Pair_t ((capture_ty, _, _), (arg_ty, _, _), _, _) ->
          let arg_stack_ty = Item_t (arg_ty, Empty_t, None) in
          let const_descr =
            ( {
                loc = descr.loc;
                bef = arg_stack_ty;
                aft = Item_t (capture_ty, arg_stack_ty, None);
                instr = Const capture;
              }
              : (_, _) descr )
          in
          let pair_descr =
            ( {
                loc = descr.loc;
                bef = Item_t (capture_ty, arg_stack_ty, None);
                aft = Item_t (full_arg_ty, Empty_t, None);
                instr = Cons_pair;
              }
              : (_, _) descr )
          in
          let seq_descr =
            ( {
                loc = descr.loc;
                bef = arg_stack_ty;
                aft = Item_t (full_arg_ty, Empty_t, None);
                instr = Seq (const_descr, pair_descr);
              }
              : (_, _) descr )
          in
          let full_descr =
            ( {
                loc = descr.loc;
                bef = arg_stack_ty;
                aft = descr.aft;
                instr = Seq (seq_descr, descr);
              }
              : (_, _) descr )
          in
          let full_expr =
            Micheline.Seq
              ( 0,
                [ Prim (0, I_PUSH, [ty_expr; const_expr], []);
                  Prim (0, I_PAIR, [], []);
                  expr ] )
          in
          let lam' = Lam (full_descr, full_expr) in
          logged_return (Item (lam', rest), ctxt)
      | _ ->
          assert false )
  | (Lambda lam, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.push)
      >>=? fun ctxt -> logged_return (Item (lam, rest), ctxt)
  | (Failwith tv, Item (v, _)) ->
      trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v)
      >>=? fun (v, _ctxt) ->
      let v = Micheline.strip_locations v in
      fail (Reject (loc, v, get_log log))
  | (Nop, stack) ->
      logged_return (stack, ctxt)
  (* comparison *)
  | (Compare ty, Item (a, Item (b, rest))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.compare ty a b))
      >>=? fun ctxt ->
      logged_return
        ( Item
            ( Script_int.of_int
              @@ Script_ir_translator.compare_comparable ty a b,
              rest ),
          ctxt )
  (* comparators *)
  | (Eq, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres = 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  | (Neq, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres <> 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  | (Lt, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres < 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  | (Le, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres <= 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  | (Gt, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres > 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  | (Ge, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres >= 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  (* packing *)
  | (Pack t, Item (value, rest)) ->
      Script_ir_translator.pack_data ctxt t value
      >>=? fun (bytes, ctxt) -> logged_return (Item (bytes, rest), ctxt)
  | (Unpack t, Item (bytes, rest)) ->
      Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes))
      >>=? fun () ->
      if
        Compare.Int.(MBytes.length bytes >= 1)
        && Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05)
      then
        let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in
        match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with
        | None ->
            Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes))
            >>=? fun ctxt -> logged_return (Item (None, rest), ctxt)
        | Some expr -> (
            Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr))
            >>=? fun ctxt ->
            parse_data ctxt ~legacy:false t (Micheline.root expr)
            >>= function
            | Ok (value, ctxt) ->
                logged_return (Item (Some value, rest), ctxt)
            | Error _ignored ->
                Lwt.return
                  (Gas.consume ctxt (Interp_costs.unpack_failed bytes))
                >>=? fun ctxt -> logged_return (Item (None, rest), ctxt) )
      else logged_return (Item (None, rest), ctxt)
  (* protocol *)
  | (Address, Item ((_, address), rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.address)
      >>=? fun ctxt -> logged_return (Item (address, rest), ctxt)
  | (Contract (t, entrypoint), Item (contract, rest)) -> (
      Lwt.return (Gas.consume ctxt Interp_costs.contract)
      >>=? fun ctxt ->
      match (contract, entrypoint) with
      | ((contract, "default"), entrypoint)
      | ((contract, entrypoint), "default") ->
          Script_ir_translator.parse_contract_for_script
            ~legacy:false
            ctxt
            loc
            t
            contract
            ~entrypoint
          >>=? fun (ctxt, maybe_contract) ->
          logged_return (Item (maybe_contract, rest), ctxt)
      | _ ->
          logged_return (Item (None, rest), ctxt) )
  | ( Transfer_tokens,
      Item (p, Item (amount, Item ((tp, (destination, entrypoint)), rest))) )
    ->
      Lwt.return (Gas.consume ctxt Interp_costs.transfer)
      >>=? fun ctxt ->
      collect_big_maps ctxt tp p
      >>=? fun (to_duplicate, ctxt) ->
      let to_update = no_big_map_id in
      extract_big_map_diff
        ctxt
        Optimized
        tp
        p
        ~to_duplicate
        ~to_update
        ~temporary:true
      >>=? fun (p, big_map_diff, ctxt) ->
      unparse_data ctxt Optimized tp p
      >>=? fun (p, ctxt) ->
      let operation =
        Transaction
          {
            amount;
            destination;
            entrypoint;
            parameters = Script.lazy_expr (Micheline.strip_locations p);
          }
      in
      Lwt.return (fresh_internal_nonce ctxt)
      >>=? fun (ctxt, nonce) ->
      logged_return
        ( Item
            ( ( Internal_operation
                  {source = step_constants.self; operation; nonce},
                big_map_diff ),
              rest ),
          ctxt )
  | ( Create_account,
      Item (manager, Item (delegate, Item (_delegatable, Item (credit, rest))))
    ) ->
      Lwt.return (Gas.consume ctxt Interp_costs.create_account)
      >>=? fun ctxt ->
      Contract.fresh_contract_from_current_nonce ctxt
      >>=? fun (ctxt, contract) ->
      (* store in optimized binary representation - as unparsed with [Optimized]. *)
      let manager_bytes =
        Data_encoding.Binary.to_bytes_exn
          Signature.Public_key_hash.encoding
          manager
      in
      let storage =
        Script_repr.lazy_expr @@ Micheline.strip_locations
        @@ Micheline.Bytes (0, manager_bytes)
      in
      let script = {code = Legacy_support.manager_script_code; storage} in
      let operation =
        Origination {credit; delegate; preorigination = Some contract; script}
      in
      Lwt.return (fresh_internal_nonce ctxt)
      >>=? fun (ctxt, nonce) ->
      logged_return
        ( Item
            ( ( Internal_operation
                  {source = step_constants.self; operation; nonce},
                None ),
              Item ((contract, "default"), rest) ),
          ctxt )
  | (Implicit_account, Item (key, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.implicit_account)
      >>=? fun ctxt ->
      let contract = Contract.implicit_contract key in
      logged_return (Item ((Unit_t None, (contract, "default")), rest), ctxt)
  | ( Create_contract (storage_type, param_type, Lam (_, code), root_name),
      Item
        ( manager,
          Item
            ( delegate,
              Item
                ( spendable,
                  Item (delegatable, Item (credit, Item (init, rest))) ) ) ) )
    ->
      Lwt.return (Gas.consume ctxt Interp_costs.create_contract)
      >>=? fun ctxt ->
      unparse_ty ctxt param_type
      >>=? fun (unparsed_param_type, ctxt) ->
      let unparsed_param_type =
        Script_ir_translator.add_field_annot
          (Option.map ~f:(fun n -> `Field_annot n) root_name)
          None
          unparsed_param_type
      in
      unparse_ty ctxt storage_type
      >>=? fun (unparsed_storage_type, ctxt) ->
      let code =
        Script.lazy_expr
        @@ Micheline.strip_locations
             (Seq
                ( 0,
                  [ Prim (0, K_parameter, [unparsed_param_type], []);
                    Prim (0, K_storage, [unparsed_storage_type], []);
                    Prim (0, K_code, [code], []) ] ))
      in
      collect_big_maps ctxt storage_type init
      >>=? fun (to_duplicate, ctxt) ->
      let to_update = no_big_map_id in
      extract_big_map_diff
        ctxt
        Optimized
        storage_type
        init
        ~to_duplicate
        ~to_update
        ~temporary:true
      >>=? fun (init, big_map_diff, ctxt) ->
      unparse_data ctxt Optimized storage_type init
      >>=? fun (storage, ctxt) ->
      let storage = Script.lazy_expr @@ Micheline.strip_locations storage in
      ( if spendable then
        Legacy_support.add_do
          ~manager_pkh:manager
          ~script_code:code
          ~script_storage:storage
      else if delegatable then
        Legacy_support.add_set_delegate
          ~manager_pkh:manager
          ~script_code:code
          ~script_storage:storage
      else if Legacy_support.has_default_entrypoint code then
        Legacy_support.add_root_entrypoint code
        >>=? fun code -> return (code, storage)
      else return (code, storage) )
      >>=? fun (code, storage) ->
      Contract.fresh_contract_from_current_nonce ctxt
      >>=? fun (ctxt, contract) ->
      let operation =
        Origination
          {
            credit;
            delegate;
            preorigination = Some contract;
            script = {code; storage};
          }
      in
      Lwt.return (fresh_internal_nonce ctxt)
      >>=? fun (ctxt, nonce) ->
      logged_return
        ( Item
            ( ( Internal_operation
                  {source = step_constants.self; operation; nonce},
                big_map_diff ),
              Item ((contract, "default"), rest) ),
          ctxt )
  | ( Create_contract_2 (storage_type, param_type, Lam (_, code), root_name),
      (* Removed the instruction's arguments manager, spendable and delegatable *)
    Item (delegate, Item (credit, Item (init, rest))) ) ->
      Lwt.return (Gas.consume ctxt Interp_costs.create_contract)
      >>=? fun ctxt ->
      unparse_ty ctxt param_type
      >>=? fun (unparsed_param_type, ctxt) ->
      let unparsed_param_type =
        Script_ir_translator.add_field_annot
          (Option.map ~f:(fun n -> `Field_annot n) root_name)
          None
          unparsed_param_type
      in
      unparse_ty ctxt storage_type
      >>=? fun (unparsed_storage_type, ctxt) ->
      let code =
        Micheline.strip_locations
          (Seq
             ( 0,
               [ Prim (0, K_parameter, [unparsed_param_type], []);
                 Prim (0, K_storage, [unparsed_storage_type], []);
                 Prim (0, K_code, [code], []) ] ))
      in
      collect_big_maps ctxt storage_type init
      >>=? fun (to_duplicate, ctxt) ->
      let to_update = no_big_map_id in
      extract_big_map_diff
        ctxt
        Optimized
        storage_type
        init
        ~to_duplicate
        ~to_update
        ~temporary:true
      >>=? fun (init, big_map_diff, ctxt) ->
      unparse_data ctxt Optimized storage_type init
      >>=? fun (storage, ctxt) ->
      let storage = Micheline.strip_locations storage in
      Contract.fresh_contract_from_current_nonce ctxt
      >>=? fun (ctxt, contract) ->
      let operation =
        Origination
          {
            credit;
            delegate;
            preorigination = Some contract;
            script =
              {
                code = Script.lazy_expr code;
                storage = Script.lazy_expr storage;
              };
          }
      in
      Lwt.return (fresh_internal_nonce ctxt)
      >>=? fun (ctxt, nonce) ->
      logged_return
        ( Item
            ( ( Internal_operation
                  {source = step_constants.self; operation; nonce},
                big_map_diff ),
              Item ((contract, "default"), rest) ),
          ctxt )
  | (Set_delegate, Item (delegate, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.create_account)
      >>=? fun ctxt ->
      let operation = Delegation delegate in
      Lwt.return (fresh_internal_nonce ctxt)
      >>=? fun (ctxt, nonce) ->
      logged_return
        ( Item
            ( ( Internal_operation
                  {source = step_constants.self; operation; nonce},
                None ),
              rest ),
          ctxt )
  | (Balance, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.balance)
      >>=? fun ctxt ->
      Contract.get_balance ctxt step_constants.self
      >>=? fun balance -> logged_return (Item (balance, rest), ctxt)
  | (Now, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.now)
      >>=? fun ctxt ->
      let now = Script_timestamp.now ctxt in
      logged_return (Item (now, rest), ctxt)
  | (Check_signature, Item (key, Item (signature, Item (message, rest)))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.check_signature key message))
      >>=? fun ctxt ->
      let res = Signature.check key signature message in
      logged_return (Item (res, rest), ctxt)
  | (Hash_key, Item (key, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.hash_key)
      >>=? fun ctxt ->
      logged_return (Item (Signature.Public_key.hash key, rest), ctxt)
  | (Blake2b, Item (bytes, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.hash_blake2b bytes))
      >>=? fun ctxt ->
      let hash = Raw_hashes.blake2b bytes in
      logged_return (Item (hash, rest), ctxt)
  | (Sha256, Item (bytes, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha256 bytes))
      >>=? fun ctxt ->
      let hash = Raw_hashes.sha256 bytes in
      logged_return (Item (hash, rest), ctxt)
  | (Sha512, Item (bytes, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha512 bytes))
      >>=? fun ctxt ->
      let hash = Raw_hashes.sha512 bytes in
      logged_return (Item (hash, rest), ctxt)
  | (Steps_to_quota, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota)
      >>=? fun ctxt ->
      let steps =
        match Gas.level ctxt with
        | Limited {remaining} ->
            remaining
        | Unaccounted ->
            Z.of_string "99999999"
      in
      logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt)
  | (Source, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.source)
      >>=? fun ctxt ->
      logged_return (Item ((step_constants.payer, "default"), rest), ctxt)
  | (Sender, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.source)
      >>=? fun ctxt ->
      logged_return (Item ((step_constants.source, "default"), rest), ctxt)
  | (Self (t, entrypoint), rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.self)
      >>=? fun ctxt ->
      logged_return (Item ((t, (step_constants.self, entrypoint)), rest), ctxt)
  | (Amount, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.amount)
      >>=? fun ctxt -> logged_return (Item (step_constants.amount, rest), ctxt)
  | (Dig (n, n'), stack) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
      >>=? fun ctxt ->
      interp_stack_prefix_preserving_operation
        (fun (Item (v, rest)) -> return (rest, v))
        n'
        stack
      >>=? fun (aft, x) -> logged_return (Item (x, aft), ctxt)
  | (Dug (n, n'), Item (v, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
      >>=? fun ctxt ->
      interp_stack_prefix_preserving_operation
        (fun stk -> return (Item (v, stk), ()))
        n'
        rest
      >>=? fun (aft, ()) -> logged_return (aft, ctxt)
  | (Dipn (n, n', b), stack) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
      >>=? fun ctxt ->
      interp_stack_prefix_preserving_operation
        (fun stk ->
          step ?log ctxt step_constants b stk
          >>=? fun (res, ctxt') -> return (res, ctxt'))
        n'
        stack
      >>=? fun (aft, ctxt') -> logged_return (aft, ctxt')
  | (Dropn (n, n'), stack) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
      >>=? fun ctxt ->
      interp_stack_prefix_preserving_operation
        (fun stk -> return (stk, stk))
        n'
        stack
      >>=? fun (_, rest) -> logged_return (rest, ctxt)
  | (ChainId, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.chain_id)
      >>=? fun ctxt ->
      logged_return (Item (step_constants.chain_id, rest), ctxt)

and interp :
    type p r.
    ?log:execution_trace ref ->
    context ->
    step_constants ->
    (p, r) lambda ->
    p ->
    (r * context) tzresult Lwt.t =
 fun ?log ctxt step_constants (Lam (code, _)) arg ->
  let stack = Item (arg, Empty) in
  ( match log with
  | None ->
      return_unit
  | Some log ->
      trace Cannot_serialize_log (unparse_stack ctxt (stack, code.bef))
      >>=? fun stack ->
      log := (code.loc, Gas.level ctxt, stack) :: !log ;
      return_unit )
  >>=? fun () ->
  step ?log ctxt step_constants code stack
  >>=? fun (Item (ret, Empty), ctxt) -> return (ret, ctxt)

(* ---- contract handling ---------------------------------------------------*)
and execute ?log ctxt mode step_constants ~entrypoint unparsed_script arg :
    ( Script.expr
    * packed_internal_operation list
    * context
    * Contract.big_map_diff option )
    tzresult
    Lwt.t =
  parse_script ctxt unparsed_script ~legacy:true
  >>=? fun (Ex_script {code; arg_type; storage; storage_type; root_name}, ctxt) ->
  trace
    (Bad_contract_parameter step_constants.self)
    (Lwt.return (find_entrypoint arg_type ~root_name entrypoint))
  >>=? fun (box, _) ->
  trace
    (Bad_contract_parameter step_constants.self)
    (parse_data ctxt ~legacy:false arg_type (box arg))
  >>=? fun (arg, ctxt) ->
  Script.force_decode ctxt unparsed_script.code
  >>=? fun (script_code, ctxt) ->
  Script_ir_translator.collect_big_maps ctxt arg_type arg
  >>=? fun (to_duplicate, ctxt) ->
  Script_ir_translator.collect_big_maps ctxt storage_type storage
  >>=? fun (to_update, ctxt) ->
  trace
    (Runtime_contract_error (step_constants.self, script_code))
    (interp ?log ctxt step_constants code (arg, storage))
  >>=? fun ((ops, storage), ctxt) ->
  Script_ir_translator.extract_big_map_diff
    ctxt
    mode
    ~temporary:false
    ~to_duplicate
    ~to_update
    storage_type
    storage
  >>=? fun (storage, big_map_diff, ctxt) ->
  trace Cannot_serialize_storage (unparse_data ctxt mode storage_type storage)
  >>=? fun (storage, ctxt) ->
  let (ops, op_diffs) = List.split ops in
  let big_map_diff =
    match
      List.flatten
        (List.map (Option.unopt ~default:[]) (op_diffs @ [big_map_diff]))
    with
    | [] ->
        None
    | diff ->
        Some diff
  in
  return (Micheline.strip_locations storage, ops, ctxt, big_map_diff)

type execution_result = {
  ctxt : context;
  storage : Script.expr;
  big_map_diff : Contract.big_map_diff option;
  operations : packed_internal_operation list;
}

let trace ctxt mode step_constants ~script ~entrypoint ~parameter =
  let log = ref [] in
  execute
    ~log
    ctxt
    mode
    step_constants
    ~entrypoint
    script
    (Micheline.root parameter)
  >>=? fun (storage, operations, ctxt, big_map_diff) ->
  let trace = List.rev !log in
  return ({ctxt; storage; big_map_diff; operations}, trace)

let execute ctxt mode step_constants ~script ~entrypoint ~parameter =
  execute
    ctxt
    mode
    step_constants
    ~entrypoint
    script
    (Micheline.root parameter)
  >>=? fun (storage, operations, ctxt, big_map_diff) ->
  return {ctxt; storage; big_map_diff; operations}
Script_interpreter.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Script_ir_annot.
Require Tezos.Script_ir_translator.
Require Tezos.Script_repr.
Require Tezos.Script_typed_ir.

Import Alpha_context.

Import Script.

Import Script_typed_ir.

Import Script_ir_translator.

Definition execution_trace :=
  list
    (Alpha_context.Script.location * Alpha_context.Gas.t *
      list (Alpha_context.Script.expr * option string)).

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Reserved Notation "'stack".

Inductive stack_gadt : Set :=
| Item : forall {ty : Set}, ty -> stack_gadt -> stack_gadt
| Empty : stack_gadt

where "'stack" := (fun (_ : Set) => stack_gadt).

Definition stack := 'stack.

Definition unparse_stack {A : Set}
  (ctxt : Alpha_context.context)
  (function_parameter : stack A * Script_typed_ir.stack_ty A)
  : Lwt.t
    (Error_monad.tzresult (list (Alpha_context.Script.expr * option string))) :=
  let '(stack, stack_ty) := function_parameter in
  let ctxt := Alpha_context.Gas.set_unlimited ctxt in
  let fix unparse_stack {a : Set}
    (function_parameter : stack a * Script_typed_ir.stack_ty a)
    {struct function_parameter}
    : Lwt.t
      (Error_monad.tzresult (list (Alpha_context.Script.expr * option string))) :=
    match function_parameter with
    | (Empty, Script_typed_ir.Empty_t) => Error_monad.return_nil
    | (Item v rest, Script_typed_ir.Item_t ty rest_ty annot) =>
      Error_monad.op_gtgteqquestion
        (Script_ir_translator.unparse_data ctxt Script_ir_translator.Readable ty
          v)
        (fun function_parameter =>
          let '(data, _ctxt) := function_parameter in
          Error_monad.op_gtgteqquestion (unparse_stack (rest, rest_ty))
            (fun rest =>
              let annot :=
                match Script_ir_annot.unparse_var_annot annot with
                | [] => None
                | cons a [] => Some a
                | _ =>
                  (* ❌ Assert instruction is not handled. *)
                  assert false
                end in
              let data := Micheline.strip_locations data in
              Error_monad.__return (cons (data, annot) rest)))
    end in
  unparse_stack (stack, stack_ty).

Module Interp_costs := Michelson_v1_gas.Cost_of.Interpreter.

Fixpoint interp_stack_prefix_preserving_operation
  {aft bef faft fbef result : Set}
  (f : stack fbef -> Lwt.t (Error_monad.tzresult (stack faft * result)))
  (n : Script_typed_ir.stack_prefix_preservation_witness fbef faft bef aft)
  (stk : stack bef) {struct f}
  : Lwt.t (Error_monad.tzresult (stack aft * result)) :=
  match (n, stk) with
  |
    (Script_typed_ir.Prefix
      (Script_typed_ir.Prefix
        (Script_typed_ir.Prefix
          (Script_typed_ir.Prefix
            (Script_typed_ir.Prefix
              (Script_typed_ir.Prefix
                (Script_typed_ir.Prefix
                  (Script_typed_ir.Prefix
                    (Script_typed_ir.Prefix
                      (Script_typed_ir.Prefix
                        (Script_typed_ir.Prefix
                          (Script_typed_ir.Prefix
                            (Script_typed_ir.Prefix
                              (Script_typed_ir.Prefix
                                (Script_typed_ir.Prefix
                                  (Script_typed_ir.Prefix n))))))))))))))),
      Item v0
        (Item v1
          (Item v2
            (Item v3
              (Item v4
                (Item v5
                  (Item v6
                    (Item v7
                      (Item v8
                        (Item v9
                          (Item va
                            (Item vb
                              (Item vc (Item vd (Item ve (Item vf rest))))))))))))))))
    =>
    Error_monad.op_gtgteqquestion
      (interp_stack_prefix_preserving_operation f n rest)
      (fun function_parameter =>
        let '(rest', __result_value) := function_parameter in
        Error_monad.__return
          ((Item v0
            (Item v1
              (Item v2
                (Item v3
                  (Item v4
                    (Item v5
                      (Item v6
                        (Item v7
                          (Item v8
                            (Item v9
                              (Item va
                                (Item vb
                                  (Item vc (Item vd (Item ve (Item vf rest')))))))))))))))),
            __result_value))
  |
    (Script_typed_ir.Prefix
      (Script_typed_ir.Prefix
        (Script_typed_ir.Prefix (Script_typed_ir.Prefix n))),
      Item v0 (Item v1 (Item v2 (Item v3 rest)))) =>
    Error_monad.op_gtgteqquestion
      (interp_stack_prefix_preserving_operation f n rest)
      (fun function_parameter =>
        let '(rest', __result_value) := function_parameter in
        Error_monad.__return
          ((Item v0 (Item v1 (Item v2 (Item v3 rest')))), __result_value))
  | (Script_typed_ir.Prefix n, Item v rest) =>
    Error_monad.op_gtgteqquestion
      (interp_stack_prefix_preserving_operation f n rest)
      (fun function_parameter =>
        let '(rest', __result_value) := function_parameter in
        Error_monad.__return ((Item v rest'), __result_value))
  | (Script_typed_ir.Rest, v) => f v
  end.

Module step_constants.
  Record record := Build {
    source : Alpha_context.Contract.t;
    payer : Alpha_context.Contract.t;
    self : Alpha_context.Contract.t;
    amount : Alpha_context.Tez.t;
    chain_id : (|Chain_id|).(S.HASH.t) }.
  Definition with_source source (r : record) :=
    Build source r.(payer) r.(self) r.(amount) r.(chain_id).
  Definition with_payer payer (r : record) :=
    Build r.(source) payer r.(self) r.(amount) r.(chain_id).
  Definition with_self self (r : record) :=
    Build r.(source) r.(payer) self r.(amount) r.(chain_id).
  Definition with_amount amount (r : record) :=
    Build r.(source) r.(payer) r.(self) amount r.(chain_id).
  Definition with_chain_id chain_id (r : record) :=
    Build r.(source) r.(payer) r.(self) r.(amount) chain_id.
End step_constants.
Definition step_constants := step_constants.record.

Fixpoint step {a b : Set}
  (log : option (Pervasives.ref execution_trace)) (ctxt : Alpha_context.context)
  (step_constants : step_constants)
  (function_parameter : Script_typed_ir.descr b a) {struct log}
  : stack b -> Lwt.t (Error_monad.tzresult (stack a * Alpha_context.context)) :=
  let
    '{|
      Script_typed_ir.descr.loc := loc;
        Script_typed_ir.descr.instr := instr
        |} as __descr_value := function_parameter in
  fun stack =>
    Error_monad.op_gtgteqquestion
      (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.cycle))
      (fun ctxt =>
        let logged_return
          (__descr_value : Script_typed_ir.descr b a)
          (function_parameter : stack a * Alpha_context.context)
          : Lwt.t (Error_monad.tzresult (stack a * Alpha_context.context)) :=
          let '(ret, ctxt) := function_parameter in
          match log with
          | None => Error_monad.__return (ret, ctxt)
          | Some log =>
            Error_monad.op_gtgteqquestion
              (Error_monad.trace extensible_type_value
                (unparse_stack ctxt
                  (ret, (Script_typed_ir.descr.aft __descr_value))))
              (fun stack =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                (* ❌ instruction_sequence ";" *)
                Error_monad.__return (ret, ctxt))
          end in
        let get_log (log : option (Pervasives.ref execution_trace))
          : option
            (list
              (Alpha_context.Script.location * Alpha_context.Gas.t *
                list (Alpha_context.Script.expr * option string))) :=
          Option.map (fun l => List.rev (Pervasives.op_exclamation l)) log in
        let consume_gas_terop {C D E arg1 arg2 arg3 rest ret : Set}
          (__descr_value :
            Script_typed_ir.descr (C * (D * (E * rest))) (ret * rest))
          (function_parameter :
            (arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3)
          : (arg1 -> arg2 -> arg3 -> Alpha_context.Gas.cost) -> stack rest ->
          Lwt.t
            (Error_monad.tzresult (stack (ret * rest) * Alpha_context.context)) :=
          let '(op, x1, x2, x3) := function_parameter in
          fun cost_func =>
            fun rest =>
              Error_monad.op_gtgteqquestion
                (Lwt.__return
                  (Alpha_context.Gas.consume ctxt (cost_func x1 x2 x3)))
                (fun ctxt =>
                  logged_return __descr_value ((Item (op x1 x2 x3) rest), ctxt))
          in
        let consume_gas_binop {C D arg1 arg2 rest ret : Set}
          (__descr_value : Script_typed_ir.descr (C * (D * rest)) (ret * rest))
          (function_parameter : (arg1 -> arg2 -> ret) * arg1 * arg2)
          : (arg1 -> arg2 -> Alpha_context.Gas.cost) -> stack rest ->
          Alpha_context.context ->
          Lwt.t
            (Error_monad.tzresult (stack (ret * rest) * Alpha_context.context)) :=
          let '(op, x1, x2) := function_parameter in
          fun cost_func =>
            fun rest =>
              fun ctxt =>
                Error_monad.op_gtgteqquestion
                  (Lwt.__return
                    (Alpha_context.Gas.consume ctxt (cost_func x1 x2)))
                  (fun ctxt =>
                    logged_return __descr_value ((Item (op x1 x2) rest), ctxt))
          in
        let consume_gas_unop {C arg rest ret : Set}
          (__descr_value : Script_typed_ir.descr (C * rest) (ret * rest))
          (function_parameter : (arg -> ret) * arg)
          : (arg -> Alpha_context.Gas.cost) -> stack rest ->
          Alpha_context.context ->
          Lwt.t
            (Error_monad.tzresult (stack (ret * rest) * Alpha_context.context)) :=
          let '(op, arg) := function_parameter in
          fun cost_func =>
            fun rest =>
              fun ctxt =>
                Error_monad.op_gtgteqquestion
                  (Lwt.__return (Alpha_context.Gas.consume ctxt (cost_func arg)))
                  (fun ctxt =>
                    logged_return __descr_value ((Item (op arg) rest), ctxt)) in
        let logged_return := logged_return __descr_value in
        match (instr, stack) with
        | (Script_typed_ir.Drop, Item _ rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.stack_op))
            (fun ctxt => logged_return (rest, ctxt))
        | (Script_typed_ir.Dup, Item v rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.stack_op))
            (fun ctxt => logged_return ((Item v (Item v rest)), ctxt))
        | (Script_typed_ir.Swap, Item vi (Item vo rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.stack_op))
            (fun ctxt => logged_return ((Item vo (Item vi rest)), ctxt))
        | (Script_typed_ir.Const v, rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.push))
            (fun ctxt => logged_return ((Item v rest), ctxt))
        | (Script_typed_ir.Cons_some, Item v rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.wrap))
            (fun ctxt => logged_return ((Item (Some v) rest), ctxt))
        | (Script_typed_ir.Cons_none _, rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.variant_no_data))
            (fun ctxt => logged_return ((Item None rest), ctxt))
        | (Script_typed_ir.If_none bt _, Item None rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.branch))
            (fun ctxt => step log ctxt step_constants bt rest)
        | (Script_typed_ir.If_none _ bf, Item (Some v) rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.branch))
            (fun ctxt => step log ctxt step_constants bf (Item v rest))
        | (Script_typed_ir.Cons_pair, Item a (Item b rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.pair))
            (fun ctxt => logged_return ((Item (a, b) rest), ctxt))
        |
          (Script_typed_ir.Seq {|
            Script_typed_ir.descr.instr := Script_typed_ir.Dup |} {|
            Script_typed_ir.descr.instr :=
              Script_typed_ir.Seq {|
                Script_typed_ir.descr.instr := Script_typed_ir.Car
                  |} {|
                Script_typed_ir.descr.instr :=
                  Script_typed_ir.Seq {|
                    Script_typed_ir.descr.instr :=
                      Script_typed_ir.Dip
                        {|
                        Script_typed_ir.descr.instr
                          :=
                          Script_typed_ir.Cdr
                          |}
                      |}
                    {|
                    Script_typed_ir.descr.instr := Script_typed_ir.Nop
                      |}
                  |}
              |}, Item (a, b) rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.pair_access))
            (fun ctxt => logged_return ((Item a (Item b rest)), ctxt))
        | (Script_typed_ir.Car, Item (a, _) rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.pair_access))
            (fun ctxt => logged_return ((Item a rest), ctxt))
        | (Script_typed_ir.Cdr, Item (_, b) rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.pair_access))
            (fun ctxt => logged_return ((Item b rest), ctxt))
        | (Script_typed_ir.Left, Item v rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.wrap))
            (fun ctxt => logged_return ((Item (Script_typed_ir.L v) rest), ctxt))
        | (Script_typed_ir.Right, Item v rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.wrap))
            (fun ctxt => logged_return ((Item (Script_typed_ir.R v) rest), ctxt))
        | (Script_typed_ir.If_left bt _, Item (Script_typed_ir.L v) rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.branch))
            (fun ctxt => step log ctxt step_constants bt (Item v rest))
        | (Script_typed_ir.If_left _ bf, Item (Script_typed_ir.R v) rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.branch))
            (fun ctxt => step log ctxt step_constants bf (Item v rest))
        | (Script_typed_ir.Cons_list, Item hd (Item tl rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.cons))
            (fun ctxt => logged_return ((Item (cons hd tl) rest), ctxt))
        | (Script_typed_ir.Nil, rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.variant_no_data))
            (fun ctxt => logged_return ((Item [] rest), ctxt))
        | (Script_typed_ir.If_cons _ bf, Item [] rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.branch))
            (fun ctxt => step log ctxt step_constants bf rest)
        | (Script_typed_ir.If_cons bt _, Item (cons hd tl) rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.branch))
            (fun ctxt =>
              step log ctxt step_constants bt (Item hd (Item tl rest)))
        | (Script_typed_ir.List_map body, Item l rest) =>
          let fix loop
            (rest : stack __49) (ctxt : Alpha_context.context) (l : list __48)
            (acc : list __50) {struct rest}
            : Lwt.t
              (Error_monad.tzresult
                (stack (list __50 * __49) * Alpha_context.context)) :=
            Error_monad.op_gtgteqquestion
              (Lwt.__return
                (Alpha_context.Gas.consume ctxt Interp_costs.loop_map))
              (fun ctxt =>
                match l with
                | [] => Error_monad.__return ((Item (List.rev acc) rest), ctxt)
                | cons hd tl =>
                  Error_monad.op_gtgteqquestion
                    (step log ctxt step_constants body (Item hd rest))
                    (fun function_parameter =>
                      let '(Item hd rest, ctxt) := function_parameter in
                      loop rest ctxt tl (cons hd acc))
                end) in
          Error_monad.op_gtgteqquestion (loop rest ctxt l [])
            (fun function_parameter =>
              let '(res, ctxt) := function_parameter in
              logged_return (res, ctxt))
        | (Script_typed_ir.List_size, Item __list_value rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (List.fold_left
                (fun acc =>
                  fun function_parameter =>
                    let '_ := function_parameter in
                    Error_monad.op_gtgtquestion acc
                      (fun function_parameter =>
                        let '(size, ctxt) := function_parameter in
                        Error_monad.op_gtgtquestion
                          (Alpha_context.Gas.consume ctxt Interp_costs.loop_size)
                          (fun ctxt =>
                            Error_monad.ok ((Pervasives.op_plus size 1), ctxt))))
                (Error_monad.ok (0, ctxt)) __list_value))
            (fun function_parameter =>
              let '(len, ctxt) := function_parameter in
              logged_return
                ((Item
                  (Alpha_context.Script_int.abs
                    (Alpha_context.Script_int.of_int len)) rest), ctxt))
        | (Script_typed_ir.List_iter body, Item l init) =>
          let fix loop
            (ctxt : Alpha_context.context) (l : list __53) (stack : stack __54)
            {struct ctxt}
            : Lwt.t (Error_monad.tzresult (stack __54 * Alpha_context.context)) :=
            Error_monad.op_gtgteqquestion
              (Lwt.__return
                (Alpha_context.Gas.consume ctxt Interp_costs.loop_iter))
              (fun ctxt =>
                match l with
                | [] => Error_monad.__return (stack, ctxt)
                | cons hd tl =>
                  Error_monad.op_gtgteqquestion
                    (step log ctxt step_constants body (Item hd stack))
                    (fun function_parameter =>
                      let '(stack, ctxt) := function_parameter in
                      loop ctxt tl stack)
                end) in
          Error_monad.op_gtgteqquestion (loop ctxt l init)
            (fun function_parameter =>
              let '(res, ctxt) := function_parameter in
              logged_return (res, ctxt))
        | (Script_typed_ir.Empty_set __t_value, rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.empty_set))
            (fun ctxt =>
              logged_return
                ((Item (Script_ir_translator.empty_set __t_value) rest), ctxt))
        | (Script_typed_ir.Set_iter body, Item set init) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt (Interp_costs.set_to_list set)))
            (fun ctxt =>
              let l :=
                List.rev
                  (Script_ir_translator.set_fold
                    (fun e => fun acc => cons e acc) set []) in
              let fix loop
                (ctxt : Alpha_context.context) (l : list __56)
                (stack : stack __57) {struct ctxt}
                : Lwt.t
                  (Error_monad.tzresult (stack __57 * Alpha_context.context)) :=
                Error_monad.op_gtgteqquestion
                  (Lwt.__return
                    (Alpha_context.Gas.consume ctxt Interp_costs.loop_iter))
                  (fun ctxt =>
                    match l with
                    | [] => Error_monad.__return (stack, ctxt)
                    | cons hd tl =>
                      Error_monad.op_gtgteqquestion
                        (step log ctxt step_constants body (Item hd stack))
                        (fun function_parameter =>
                          let '(stack, ctxt) := function_parameter in
                          loop ctxt tl stack)
                    end) in
              Error_monad.op_gtgteqquestion (loop ctxt l init)
                (fun function_parameter =>
                  let '(res, ctxt) := function_parameter in
                  logged_return (res, ctxt)))
        | (Script_typed_ir.Set_mem, Item v (Item set rest)) =>
          consume_gas_binop __descr_value (Script_ir_translator.set_mem, v, set)
            Interp_costs.set_mem rest ctxt
        | (Script_typed_ir.Set_update, Item v (Item presence (Item set rest)))
          =>
          consume_gas_terop __descr_value
            (Script_ir_translator.set_update, v, presence, set)
            Interp_costs.set_update rest
        | (Script_typed_ir.Set_size, Item set rest) =>
          consume_gas_unop __descr_value (Script_ir_translator.set_size, set)
            (fun function_parameter =>
              let '_ := function_parameter in
              Interp_costs.set_size) rest ctxt
        | (Script_typed_ir.Empty_map __t_value _, rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.empty_map))
            (fun ctxt =>
              logged_return
                ((Item (Script_ir_translator.empty_map __t_value) rest), ctxt))
        | (Script_typed_ir.Map_map body, Item map rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt (Interp_costs.map_to_list map)))
            (fun ctxt =>
              let l :=
                List.rev
                  (Script_ir_translator.map_fold
                    (fun k => fun v => fun acc => cons (k, v) acc) map []) in
              let fix loop
                (rest : stack __68) (ctxt : Alpha_context.context)
                (l : list (__66 * __67)) (acc : Script_typed_ir.map __66 __69)
                {struct rest}
                : Lwt.t
                  (Error_monad.tzresult
                    (Script_typed_ir.map __66 __69 * Alpha_context.context)) :=
                Error_monad.op_gtgteqquestion
                  (Lwt.__return
                    (Alpha_context.Gas.consume ctxt Interp_costs.loop_map))
                  (fun ctxt =>
                    match l with
                    | [] => Error_monad.__return (acc, ctxt)
                    | cons ((k, _) as hd) tl =>
                      Error_monad.op_gtgteqquestion
                        (step log ctxt step_constants body (Item hd rest))
                        (fun function_parameter =>
                          let '(Item hd rest, ctxt) := function_parameter in
                          loop rest ctxt tl
                            (Script_ir_translator.map_update k (Some hd) acc))
                    end) in
              Error_monad.op_gtgteqquestion
                (loop rest ctxt l
                  (Script_ir_translator.empty_map
                    (Script_ir_translator.map_key_ty map)))
                (fun function_parameter =>
                  let '(res, ctxt) := function_parameter in
                  logged_return ((Item res rest), ctxt)))
        | (Script_typed_ir.Map_iter body, Item map init) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt (Interp_costs.map_to_list map)))
            (fun ctxt =>
              let l :=
                List.rev
                  (Script_ir_translator.map_fold
                    (fun k => fun v => fun acc => cons (k, v) acc) map []) in
              let fix loop
                (ctxt : Alpha_context.context) (l : list (__70 * __71))
                (stack : stack __72) {struct ctxt}
                : Lwt.t
                  (Error_monad.tzresult (stack __72 * Alpha_context.context)) :=
                Error_monad.op_gtgteqquestion
                  (Lwt.__return
                    (Alpha_context.Gas.consume ctxt Interp_costs.loop_iter))
                  (fun ctxt =>
                    match l with
                    | [] => Error_monad.__return (stack, ctxt)
                    | cons hd tl =>
                      Error_monad.op_gtgteqquestion
                        (step log ctxt step_constants body (Item hd stack))
                        (fun function_parameter =>
                          let '(stack, ctxt) := function_parameter in
                          loop ctxt tl stack)
                    end) in
              Error_monad.op_gtgteqquestion (loop ctxt l init)
                (fun function_parameter =>
                  let '(res, ctxt) := function_parameter in
                  logged_return (res, ctxt)))
        | (Script_typed_ir.Map_mem, Item v (Item map rest)) =>
          consume_gas_binop __descr_value (Script_ir_translator.map_mem, v, map)
            Interp_costs.map_mem rest ctxt
        | (Script_typed_ir.Map_get, Item v (Item map rest)) =>
          consume_gas_binop __descr_value (Script_ir_translator.map_get, v, map)
            Interp_costs.map_get rest ctxt
        | (Script_typed_ir.Map_update, Item k (Item v (Item map rest))) =>
          consume_gas_terop __descr_value
            (Script_ir_translator.map_update, k, v, map) Interp_costs.map_update
            rest
        | (Script_typed_ir.Map_size, Item map rest) =>
          consume_gas_unop __descr_value (Script_ir_translator.map_size, map)
            (fun function_parameter =>
              let '_ := function_parameter in
              Interp_costs.map_size) rest ctxt
        | (Script_typed_ir.Empty_big_map tk tv, rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.empty_map))
            (fun ctxt =>
              logged_return
                ((Item (Script_ir_translator.empty_big_map tk tv) rest), ctxt))
        | (Script_typed_ir.Big_map_mem, Item key (Item map rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt
                (Interp_costs.map_mem key (Script_typed_ir.big_map.diff map))))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (Script_ir_translator.big_map_mem ctxt key map)
                (fun function_parameter =>
                  let '(res, ctxt) := function_parameter in
                  logged_return ((Item res rest), ctxt)))
        | (Script_typed_ir.Big_map_get, Item key (Item map rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt
                (Interp_costs.map_get key (Script_typed_ir.big_map.diff map))))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (Script_ir_translator.big_map_get ctxt key map)
                (fun function_parameter =>
                  let '(res, ctxt) := function_parameter in
                  logged_return ((Item res rest), ctxt)))
        |
          (Script_typed_ir.Big_map_update,
            Item key (Item maybe_value (Item map rest))) =>
          consume_gas_terop __descr_value
            (Script_ir_translator.big_map_update, key, maybe_value, map)
            (fun k =>
              fun v =>
                fun m =>
                  Interp_costs.map_update k (Some v)
                    (Script_typed_ir.big_map.diff m)) rest
        |
          (Script_typed_ir.Add_seconds_to_timestamp,
            Item n (Item __t_value rest)) =>
          consume_gas_binop __descr_value
            (Alpha_context.Script_timestamp.add_delta, __t_value, n)
            Interp_costs.add_timestamp rest ctxt
        |
          (Script_typed_ir.Add_timestamp_to_seconds,
            Item __t_value (Item n rest)) =>
          consume_gas_binop __descr_value
            (Alpha_context.Script_timestamp.add_delta, __t_value, n)
            Interp_costs.add_timestamp rest ctxt
        | (Script_typed_ir.Sub_timestamp_seconds, Item __t_value (Item s rest))
          =>
          consume_gas_binop __descr_value
            (Alpha_context.Script_timestamp.sub_delta, __t_value, s)
            Interp_costs.sub_timestamp rest ctxt
        | (Script_typed_ir.Diff_timestamps, Item t1 (Item t2 rest)) =>
          consume_gas_binop __descr_value
            (Alpha_context.Script_timestamp.diff, t1, t2)
            Interp_costs.diff_timestamps rest ctxt
        | (Script_typed_ir.Concat_string_pair, Item x (Item y rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt
                (Interp_costs.concat_string [ x; y ])))
            (fun ctxt =>
              let s := String.concat "" [ x; y ] in
              logged_return ((Item s rest), ctxt))
        | (Script_typed_ir.Concat_string, Item ss rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt (Interp_costs.concat_string ss)))
            (fun ctxt =>
              let s := String.concat "" ss in
              logged_return ((Item s rest), ctxt))
        |
          (Script_typed_ir.Slice_string, Item offset (Item length (Item s rest)))
          =>
          let s_length := Z.of_int (String.length s) in
          let offset := Alpha_context.Script_int.to_zint offset in
          let length := Alpha_context.Script_int.to_zint length in
          if
            Pervasives.op_andand
              ((|Compare.Z|).(Compare.S.op_lt) offset s_length)
              ((|Compare.Z|).(Compare.S.op_lteq) (Z.add offset length) s_length)
            then
            Error_monad.op_gtgteqquestion
              (Lwt.__return
                (Alpha_context.Gas.consume ctxt
                  (Interp_costs.slice_string (Z.to_int length))))
              (fun ctxt =>
                logged_return
                  ((Item
                    (Some (String.sub s (Z.to_int offset) (Z.to_int length)))
                    rest), ctxt))
          else
            Error_monad.op_gtgteqquestion
              (Lwt.__return
                (Alpha_context.Gas.consume ctxt (Interp_costs.slice_string 0)))
              (fun ctxt => logged_return ((Item None rest), ctxt))
        | (Script_typed_ir.String_size, Item s rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.push))
            (fun ctxt =>
              logged_return
                ((Item
                  (Alpha_context.Script_int.abs
                    (Alpha_context.Script_int.of_int (String.length s))) rest),
                  ctxt))
        | (Script_typed_ir.Concat_bytes_pair, Item x (Item y rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt
                (Interp_costs.concat_bytes [ x; y ])))
            (fun ctxt =>
              let s := MBytes.concat "" [ x; y ] in
              logged_return ((Item s rest), ctxt))
        | (Script_typed_ir.Concat_bytes, Item ss rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt (Interp_costs.concat_bytes ss)))
            (fun ctxt =>
              let s := MBytes.concat "" ss in
              logged_return ((Item s rest), ctxt))
        | (Script_typed_ir.Slice_bytes, Item offset (Item length (Item s rest)))
          =>
          let s_length := Z.of_int (MBytes.length s) in
          let offset := Alpha_context.Script_int.to_zint offset in
          let length := Alpha_context.Script_int.to_zint length in
          if
            Pervasives.op_andand
              ((|Compare.Z|).(Compare.S.op_lt) offset s_length)
              ((|Compare.Z|).(Compare.S.op_lteq) (Z.add offset length) s_length)
            then
            Error_monad.op_gtgteqquestion
              (Lwt.__return
                (Alpha_context.Gas.consume ctxt
                  (Interp_costs.slice_string (Z.to_int length))))
              (fun ctxt =>
                logged_return
                  ((Item
                    (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)))
                    rest), ctxt))
          else
            Error_monad.op_gtgteqquestion
              (Lwt.__return
                (Alpha_context.Gas.consume ctxt (Interp_costs.slice_string 0)))
              (fun ctxt => logged_return ((Item None rest), ctxt))
        | (Script_typed_ir.Bytes_size, Item s rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.push))
            (fun ctxt =>
              logged_return
                ((Item
                  (Alpha_context.Script_int.abs
                    (Alpha_context.Script_int.of_int (MBytes.length s))) rest),
                  ctxt))
        | (Script_typed_ir.Add_tez, Item x (Item y rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.int64_op))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (Lwt.__return (Alpha_context.Tez.op_plusquestion x y))
                (fun res => logged_return ((Item res rest), ctxt)))
        | (Script_typed_ir.Sub_tez, Item x (Item y rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.int64_op))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (Lwt.__return (Alpha_context.Tez.op_minusquestion x y))
                (fun res => logged_return ((Item res rest), ctxt)))
        | (Script_typed_ir.Mul_teznat, Item x (Item y rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.int64_op))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (Lwt.__return
                  (Alpha_context.Gas.consume ctxt Interp_costs.z_to_int64))
                (fun ctxt =>
                  match Alpha_context.Script_int.to_int64 y with
                  | None => Error_monad.fail extensible_type_value
                  | Some y =>
                    Error_monad.op_gtgteqquestion
                      (Lwt.__return (Alpha_context.Tez.op_starquestion x y))
                      (fun res => logged_return ((Item res rest), ctxt))
                  end))
        | (Script_typed_ir.Mul_nattez, Item y (Item x rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.int64_op))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (Lwt.__return
                  (Alpha_context.Gas.consume ctxt Interp_costs.z_to_int64))
                (fun ctxt =>
                  match Alpha_context.Script_int.to_int64 y with
                  | None => Error_monad.fail extensible_type_value
                  | Some y =>
                    Error_monad.op_gtgteqquestion
                      (Lwt.__return (Alpha_context.Tez.op_starquestion x y))
                      (fun res => logged_return ((Item res rest), ctxt))
                  end))
        | (Script_typed_ir.Or, Item x (Item y rest)) =>
          consume_gas_binop __descr_value (Pervasives.op_pipepipe, x, y)
            Interp_costs.bool_binop rest ctxt
        | (Script_typed_ir.And, Item x (Item y rest)) =>
          consume_gas_binop __descr_value (Pervasives.op_andand, x, y)
            Interp_costs.bool_binop rest ctxt
        | (Script_typed_ir.Xor, Item x (Item y rest)) =>
          consume_gas_binop __descr_value
            ((|Compare.Bool|).(Compare.S.op_ltgt), x, y) Interp_costs.bool_binop
            rest ctxt
        | (Script_typed_ir.Not, Item x rest) =>
          consume_gas_unop __descr_value (Pervasives.not, x)
            Interp_costs.bool_unop rest ctxt
        | (Script_typed_ir.Is_nat, Item x rest) =>
          consume_gas_unop __descr_value (Alpha_context.Script_int.is_nat, x)
            Interp_costs.abs rest ctxt
        | (Script_typed_ir.Abs_int, Item x rest) =>
          consume_gas_unop __descr_value (Alpha_context.Script_int.abs, x)
            Interp_costs.abs rest ctxt
        | (Script_typed_ir.Int_nat, Item x rest) =>
          consume_gas_unop __descr_value (Alpha_context.Script_int.int, x)
            Interp_costs.int rest ctxt
        | (Script_typed_ir.Neg_int, Item x rest) =>
          consume_gas_unop __descr_value (Alpha_context.Script_int.neg, x)
            Interp_costs.neg rest ctxt
        | (Script_typed_ir.Neg_nat, Item x rest) =>
          consume_gas_unop __descr_value (Alpha_context.Script_int.neg, x)
            Interp_costs.neg rest ctxt
        | (Script_typed_ir.Add_intint, Item x (Item y rest)) =>
          consume_gas_binop __descr_value (Alpha_context.Script_int.add, x, y)
            Interp_costs.add rest ctxt
        | (Script_typed_ir.Add_intnat, Item x (Item y rest)) =>
          consume_gas_binop __descr_value (Alpha_context.Script_int.add, x, y)
            Interp_costs.add rest ctxt
        | (Script_typed_ir.Add_natint, Item x (Item y rest)) =>
          consume_gas_binop __descr_value (Alpha_context.Script_int.add, x, y)
            Interp_costs.add rest ctxt
        | (Script_typed_ir.Add_natnat, Item x (Item y rest)) =>
          consume_gas_binop __descr_value (Alpha_context.Script_int.add_n, x, y)
            Interp_costs.add rest ctxt
        | (Script_typed_ir.Sub_int, Item x (Item y rest)) =>
          consume_gas_binop __descr_value (Alpha_context.Script_int.sub, x, y)
            Interp_costs.sub rest ctxt
        | (Script_typed_ir.Mul_intint, Item x (Item y rest)) =>
          consume_gas_binop __descr_value (Alpha_context.Script_int.mul, x, y)
            Interp_costs.mul rest ctxt
        | (Script_typed_ir.Mul_intnat, Item x (Item y rest)) =>
          consume_gas_binop __descr_value (Alpha_context.Script_int.mul, x, y)
            Interp_costs.mul rest ctxt
        | (Script_typed_ir.Mul_natint, Item x (Item y rest)) =>
          consume_gas_binop __descr_value (Alpha_context.Script_int.mul, x, y)
            Interp_costs.mul rest ctxt
        | (Script_typed_ir.Mul_natnat, Item x (Item y rest)) =>
          consume_gas_binop __descr_value (Alpha_context.Script_int.mul_n, x, y)
            Interp_costs.mul rest ctxt
        | (Script_typed_ir.Ediv_teznat, Item x (Item y rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.int64_to_z))
            (fun ctxt =>
              let x :=
                Alpha_context.Script_int.of_int64 (Alpha_context.Tez.to_mutez x)
                in
              consume_gas_binop __descr_value
                ((fun x =>
                  fun y =>
                    match Alpha_context.Script_int.ediv x y with
                    | None => None
                    | Some (q, r) =>
                      match
                        ((Alpha_context.Script_int.to_int64 q),
                          (Alpha_context.Script_int.to_int64 r)) with
                      | (Some q, Some r) =>
                        match
                          ((Alpha_context.Tez.of_mutez q),
                            (Alpha_context.Tez.of_mutez r)) with
                        | (Some q, Some r) => Some (q, r)
                        | _ =>
                          (* ❌ Assert instruction is not handled. *)
                          assert false
                        end
                      | _ =>
                        (* ❌ Assert instruction is not handled. *)
                        assert false
                      end
                    end), x, y) Interp_costs.div rest ctxt)
        | (Script_typed_ir.Ediv_tez, Item x (Item y rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.int64_to_z))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (Lwt.__return
                  (Alpha_context.Gas.consume ctxt Interp_costs.int64_to_z))
                (fun ctxt =>
                  let x :=
                    Alpha_context.Script_int.abs
                      (Alpha_context.Script_int.of_int64
                        (Alpha_context.Tez.to_mutez x)) in
                  let y :=
                    Alpha_context.Script_int.abs
                      (Alpha_context.Script_int.of_int64
                        (Alpha_context.Tez.to_mutez y)) in
                  consume_gas_binop __descr_value
                    ((fun x =>
                      fun y =>
                        match Alpha_context.Script_int.ediv_n x y with
                        | None => None
                        | Some (q, r) =>
                          match Alpha_context.Script_int.to_int64 r with
                          | None =>
                            (* ❌ Assert instruction is not handled. *)
                            assert false
                          | Some r =>
                            match Alpha_context.Tez.of_mutez r with
                            | None =>
                              (* ❌ Assert instruction is not handled. *)
                              assert false
                            | Some r => Some (q, r)
                            end
                          end
                        end), x, y) Interp_costs.div rest ctxt))
        | (Script_typed_ir.Ediv_intint, Item x (Item y rest)) =>
          consume_gas_binop __descr_value (Alpha_context.Script_int.ediv, x, y)
            Interp_costs.div rest ctxt
        | (Script_typed_ir.Ediv_intnat, Item x (Item y rest)) =>
          consume_gas_binop __descr_value (Alpha_context.Script_int.ediv, x, y)
            Interp_costs.div rest ctxt
        | (Script_typed_ir.Ediv_natint, Item x (Item y rest)) =>
          consume_gas_binop __descr_value (Alpha_context.Script_int.ediv, x, y)
            Interp_costs.div rest ctxt
        | (Script_typed_ir.Ediv_natnat, Item x (Item y rest)) =>
          consume_gas_binop __descr_value
            (Alpha_context.Script_int.ediv_n, x, y) Interp_costs.div rest ctxt
        | (Script_typed_ir.Lsl_nat, Item x (Item y rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt (Interp_costs.shift_left x y)))
            (fun ctxt =>
              match Alpha_context.Script_int.shift_left_n x y with
              | None => Error_monad.fail extensible_type_value
              | Some x => logged_return ((Item x rest), ctxt)
              end)
        | (Script_typed_ir.Lsr_nat, Item x (Item y rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt (Interp_costs.shift_right x y)))
            (fun ctxt =>
              match Alpha_context.Script_int.shift_right_n x y with
              | None => Error_monad.fail extensible_type_value
              | Some r => logged_return ((Item r rest), ctxt)
              end)
        | (Script_typed_ir.Or_nat, Item x (Item y rest)) =>
          consume_gas_binop __descr_value (Alpha_context.Script_int.logor, x, y)
            Interp_costs.logor rest ctxt
        | (Script_typed_ir.And_nat, Item x (Item y rest)) =>
          consume_gas_binop __descr_value
            (Alpha_context.Script_int.logand, x, y) Interp_costs.logand rest
            ctxt
        | (Script_typed_ir.And_int_nat, Item x (Item y rest)) =>
          consume_gas_binop __descr_value
            (Alpha_context.Script_int.logand, x, y) Interp_costs.logand rest
            ctxt
        | (Script_typed_ir.Xor_nat, Item x (Item y rest)) =>
          consume_gas_binop __descr_value
            (Alpha_context.Script_int.logxor, x, y) Interp_costs.logxor rest
            ctxt
        | (Script_typed_ir.Not_int, Item x rest) =>
          consume_gas_unop __descr_value (Alpha_context.Script_int.lognot, x)
            Interp_costs.lognot rest ctxt
        | (Script_typed_ir.Not_nat, Item x rest) =>
          consume_gas_unop __descr_value (Alpha_context.Script_int.lognot, x)
            Interp_costs.lognot rest ctxt
        | (Script_typed_ir.Seq hd tl, stack) =>
          Error_monad.op_gtgteqquestion (step log ctxt step_constants hd stack)
            (fun function_parameter =>
              let '(trans, ctxt) := function_parameter in
              step log ctxt step_constants tl trans)
        | (Script_typed_ir.If bt _, Item true rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.branch))
            (fun ctxt => step log ctxt step_constants bt rest)
        | (Script_typed_ir.If _ bf, Item false rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.branch))
            (fun ctxt => step log ctxt step_constants bf rest)
        | (Script_typed_ir.Loop body, Item true rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.loop_cycle))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (step log ctxt step_constants body rest)
                (fun function_parameter =>
                  let '(trans, ctxt) := function_parameter in
                  step log ctxt step_constants __descr_value trans))
        | (Script_typed_ir.Loop _, Item false rest) =>
          logged_return (rest, ctxt)
        | (Script_typed_ir.Loop_left body, Item (Script_typed_ir.L v) rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.loop_cycle))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (step log ctxt step_constants body (Item v rest))
                (fun function_parameter =>
                  let '(trans, ctxt) := function_parameter in
                  step log ctxt step_constants __descr_value trans))
        | (Script_typed_ir.Loop_left _, Item (Script_typed_ir.R v) rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.loop_cycle))
            (fun ctxt => logged_return ((Item v rest), ctxt))
        | (Script_typed_ir.Dip b, Item ign rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.stack_op))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (step log ctxt step_constants b rest)
                (fun function_parameter =>
                  let '(res, ctxt) := function_parameter in
                  logged_return ((Item ign res), ctxt)))
        | (Script_typed_ir.Exec, Item arg (Item lam rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.exec))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (interp log ctxt step_constants lam arg)
                (fun function_parameter =>
                  let '(res, ctxt) := function_parameter in
                  logged_return ((Item res rest), ctxt)))
        | (Script_typed_ir.Apply capture_ty, Item capture (Item lam rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.apply))
            (fun ctxt =>
              let 'Script_typed_ir.Lam __descr_value expr := lam in
              let 'Script_typed_ir.Item_t full_arg_ty _ _ :=
                Script_typed_ir.descr.bef __descr_value in
              Error_monad.op_gtgteqquestion
                (Script_ir_translator.unparse_data ctxt
                  Script_ir_translator.Optimized capture_ty capture)
                (fun function_parameter =>
                  let '(const_expr, ctxt) := function_parameter in
                  Error_monad.op_gtgteqquestion
                    (Script_ir_translator.unparse_ty ctxt capture_ty)
                    (fun function_parameter =>
                      let '(ty_expr, ctxt) := function_parameter in
                      match full_arg_ty with
                      |
                        Script_typed_ir.Pair_t (capture_ty, _, _) (arg_ty, _, _)
                          _ _ =>
                        let arg_stack_ty :=
                          Script_typed_ir.Item_t arg_ty Script_typed_ir.Empty_t
                            None in
                        let const_descr :=
                          {|
                            Script_typed_ir.descr.loc :=
                              Script_typed_ir.descr.loc __descr_value;
                            Script_typed_ir.descr.bef := arg_stack_ty;
                            Script_typed_ir.descr.aft :=
                              Script_typed_ir.Item_t capture_ty arg_stack_ty
                                None;
                            Script_typed_ir.descr.instr :=
                              Script_typed_ir.Const capture |} in
                        let pair_descr :=
                          {|
                            Script_typed_ir.descr.loc :=
                              Script_typed_ir.descr.loc __descr_value;
                            Script_typed_ir.descr.bef :=
                              Script_typed_ir.Item_t capture_ty arg_stack_ty
                                None;
                            Script_typed_ir.descr.aft :=
                              Script_typed_ir.Item_t full_arg_ty
                                Script_typed_ir.Empty_t None;
                            Script_typed_ir.descr.instr :=
                              Script_typed_ir.Cons_pair |} in
                        let seq_descr :=
                          {|
                            Script_typed_ir.descr.loc :=
                              Script_typed_ir.descr.loc __descr_value;
                            Script_typed_ir.descr.bef := arg_stack_ty;
                            Script_typed_ir.descr.aft :=
                              Script_typed_ir.Item_t full_arg_ty
                                Script_typed_ir.Empty_t None;
                            Script_typed_ir.descr.instr :=
                              Script_typed_ir.Seq const_descr pair_descr |} in
                        let full_descr :=
                          {|
                            Script_typed_ir.descr.loc :=
                              Script_typed_ir.descr.loc __descr_value;
                            Script_typed_ir.descr.bef := arg_stack_ty;
                            Script_typed_ir.descr.aft :=
                              Script_typed_ir.descr.aft __descr_value;
                            Script_typed_ir.descr.instr :=
                              Script_typed_ir.Seq seq_descr __descr_value |} in
                        let full_expr :=
                          Micheline.Seq 0
                            [
                              Micheline.Prim 0 Alpha_context.Script.I_PUSH
                                [ ty_expr; const_expr ]
                                [];
                              Micheline.Prim 0 Alpha_context.Script.I_PAIR [] [];
                              expr
                            ] in
                        let lam' := Script_typed_ir.Lam full_descr full_expr in
                        logged_return ((Item lam' rest), ctxt)
                      | _ =>
                        (* ❌ Assert instruction is not handled. *)
                        assert false
                      end)))
        | (Script_typed_ir.Lambda lam, rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.push))
            (fun ctxt => logged_return ((Item lam rest), ctxt))
        | (Script_typed_ir.Failwith tv, Item v _) =>
          Error_monad.op_gtgteqquestion
            (Error_monad.trace extensible_type_value
              (Script_ir_translator.unparse_data ctxt
                Script_ir_translator.Optimized tv v))
            (fun function_parameter =>
              let '(v, _ctxt) := function_parameter in
              let v := Micheline.strip_locations v in
              Error_monad.fail extensible_type_value)
        | (Script_typed_ir.Nop, stack) => logged_return (stack, ctxt)
        | (Script_typed_ir.Compare ty, Item a (Item b rest)) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt (Interp_costs.compare ty a b)))
            (fun ctxt =>
              logged_return
                ((Item
                  (Pervasives.op_atat Alpha_context.Script_int.of_int
                    (Script_ir_translator.compare_comparable ty a b)) rest),
                  ctxt))
        | (Script_typed_ir.Eq, Item cmpres rest) =>
          let cmpres :=
            Alpha_context.Script_int.compare cmpres
              Alpha_context.Script_int.zero in
          let cmpres := (|Compare.Int|).(Compare.S.op_eq) cmpres 0 in
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.compare_res))
            (fun ctxt => logged_return ((Item cmpres rest), ctxt))
        | (Script_typed_ir.Neq, Item cmpres rest) =>
          let cmpres :=
            Alpha_context.Script_int.compare cmpres
              Alpha_context.Script_int.zero in
          let cmpres := (|Compare.Int|).(Compare.S.op_ltgt) cmpres 0 in
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.compare_res))
            (fun ctxt => logged_return ((Item cmpres rest), ctxt))
        | (Script_typed_ir.Lt, Item cmpres rest) =>
          let cmpres :=
            Alpha_context.Script_int.compare cmpres
              Alpha_context.Script_int.zero in
          let cmpres := (|Compare.Int|).(Compare.S.op_lt) cmpres 0 in
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.compare_res))
            (fun ctxt => logged_return ((Item cmpres rest), ctxt))
        | (Script_typed_ir.Le, Item cmpres rest) =>
          let cmpres :=
            Alpha_context.Script_int.compare cmpres
              Alpha_context.Script_int.zero in
          let cmpres := (|Compare.Int|).(Compare.S.op_lteq) cmpres 0 in
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.compare_res))
            (fun ctxt => logged_return ((Item cmpres rest), ctxt))
        | (Script_typed_ir.Gt, Item cmpres rest) =>
          let cmpres :=
            Alpha_context.Script_int.compare cmpres
              Alpha_context.Script_int.zero in
          let cmpres := (|Compare.Int|).(Compare.S.op_gt) cmpres 0 in
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.compare_res))
            (fun ctxt => logged_return ((Item cmpres rest), ctxt))
        | (Script_typed_ir.Ge, Item cmpres rest) =>
          let cmpres :=
            Alpha_context.Script_int.compare cmpres
              Alpha_context.Script_int.zero in
          let cmpres := (|Compare.Int|).(Compare.S.op_gteq) cmpres 0 in
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.compare_res))
            (fun ctxt => logged_return ((Item cmpres rest), ctxt))
        | (Script_typed_ir.Pack __t_value, Item value rest) =>
          Error_monad.op_gtgteqquestion
            (Script_ir_translator.pack_data ctxt __t_value value)
            (fun function_parameter =>
              let '(__bytes_value, ctxt) := function_parameter in
              logged_return ((Item __bytes_value rest), ctxt))
        | (Script_typed_ir.Unpack __t_value, Item __bytes_value rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.check_enough ctxt
                (Alpha_context.Script.serialized_cost __bytes_value)))
            (fun function_parameter =>
              let '_ := function_parameter in
              if
                Pervasives.op_andand
                  ((|Compare.Int|).(Compare.S.op_gteq)
                    (MBytes.length __bytes_value) 1)
                  ((|Compare.Int|).(Compare.S.op_eq)
                    (MBytes.get_uint8 __bytes_value 0) 5) then
                let __bytes_value :=
                  MBytes.sub __bytes_value 1
                    (Pervasives.op_minus (MBytes.length __bytes_value) 1) in
                match
                  Data_encoding.Binary.of_bytes
                    Alpha_context.Script.expr_encoding __bytes_value with
                | None =>
                  Error_monad.op_gtgteqquestion
                    (Lwt.__return
                      (Alpha_context.Gas.consume ctxt
                        (Interp_costs.unpack_failed __bytes_value)))
                    (fun ctxt => logged_return ((Item None rest), ctxt))
                | Some expr =>
                  Error_monad.op_gtgteqquestion
                    (Lwt.__return
                      (Alpha_context.Gas.consume ctxt
                        (Alpha_context.Script.deserialized_cost expr)))
                    (fun ctxt =>
                      Error_monad.op_gtgteq
                        (Script_ir_translator.parse_data None ctxt false
                          __t_value (Micheline.root expr))
                        (fun function_parameter =>
                          match function_parameter with
                          | Pervasives.Ok (value, ctxt) =>
                            logged_return ((Item (Some value) rest), ctxt)
                          | Pervasives.Error _ignored =>
                            Error_monad.op_gtgteqquestion
                              (Lwt.__return
                                (Alpha_context.Gas.consume ctxt
                                  (Interp_costs.unpack_failed __bytes_value)))
                              (fun ctxt =>
                                logged_return ((Item None rest), ctxt))
                          end))
                end
              else
                logged_return ((Item None rest), ctxt))
        | (Script_typed_ir.Address, Item (_, address) rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.address))
            (fun ctxt => logged_return ((Item address rest), ctxt))
        | (Script_typed_ir.Contract __t_value entrypoint, Item contract rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.contract))
            (fun ctxt =>
              match (contract, entrypoint) with
              |
                ((contract, "default"), entrypoint) |
                ((contract, entrypoint), "default") =>
                Error_monad.op_gtgteqquestion
                  (Script_ir_translator.parse_contract_for_script false ctxt loc
                    __t_value contract entrypoint)
                  (fun function_parameter =>
                    let '(ctxt, maybe_contract) := function_parameter in
                    logged_return ((Item maybe_contract rest), ctxt))
              | _ => logged_return ((Item None rest), ctxt)
              end)
        |
          (Script_typed_ir.Transfer_tokens,
            Item p (Item amount (Item (tp, (destination, entrypoint)) rest))) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.transfer))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (Script_ir_translator.collect_big_maps ctxt tp p)
                (fun function_parameter =>
                  let '(to_duplicate, ctxt) := function_parameter in
                  let to_update := Script_ir_translator.no_big_map_id in
                  Error_monad.op_gtgteqquestion
                    (Script_ir_translator.extract_big_map_diff ctxt
                      Script_ir_translator.Optimized true to_duplicate to_update
                      tp p)
                    (fun function_parameter =>
                      let '(p, big_map_diff, ctxt) := function_parameter in
                      Error_monad.op_gtgteqquestion
                        (Script_ir_translator.unparse_data ctxt
                          Script_ir_translator.Optimized tp p)
                        (fun function_parameter =>
                          let '(p, ctxt) := function_parameter in
                          let operation :=
                            Alpha_context.Transaction
                              {|
                                Alpha_context.manager_operation.Transaction.amount :=
                                  amount;
                                Alpha_context.manager_operation.Transaction.parameters :=
                                  Alpha_context.Script.__lazy_expr_value
                                    (Micheline.strip_locations p);
                                Alpha_context.manager_operation.Transaction.entrypoint :=
                                  entrypoint;
                                Alpha_context.manager_operation.Transaction.destination :=
                                  destination |} in
                          Error_monad.op_gtgteqquestion
                            (Lwt.__return
                              (Alpha_context.fresh_internal_nonce ctxt))
                            (fun function_parameter =>
                              let '(ctxt, __nonce_value) := function_parameter
                                in
                              logged_return
                                ((Item
                                  ((Alpha_context.Internal_operation
                                    {|
                                      Alpha_context.internal_operation.source :=
                                        step_constants.self step_constants;
                                      Alpha_context.internal_operation.operation :=
                                        operation;
                                      Alpha_context.internal_operation.nonce :=
                                        __nonce_value |}), big_map_diff) rest),
                                  ctxt))))))
        |
          (Script_typed_ir.Create_account,
            Item manager (Item delegate (Item _delegatable (Item credit rest))))
          =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.create_account))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (Alpha_context.Contract.fresh_contract_from_current_nonce ctxt)
                (fun function_parameter =>
                  let '(ctxt, contract) := function_parameter in
                  let manager_bytes :=
                    Data_encoding.Binary.to_bytes_exn
                      (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding)
                      manager in
                  let storage :=
                    Pervasives.op_atat Script_repr.__lazy_expr_value
                      (Pervasives.op_atat Micheline.strip_locations
                        (Micheline.Bytes 0 manager_bytes)) in
                  let script :=
                    {|
                      Alpha_context.Script.t.code :=
                        Alpha_context.Script.Legacy_support.manager_script_code;
                      Alpha_context.Script.t.storage := storage |} in
                  let operation :=
                    Alpha_context.Origination
                      {|
                        Alpha_context.manager_operation.Origination.delegate :=
                          delegate;
                        Alpha_context.manager_operation.Origination.script :=
                          script;
                        Alpha_context.manager_operation.Origination.credit :=
                          credit;
                        Alpha_context.manager_operation.Origination.preorigination :=
                          Some contract |} in
                  Error_monad.op_gtgteqquestion
                    (Lwt.__return (Alpha_context.fresh_internal_nonce ctxt))
                    (fun function_parameter =>
                      let '(ctxt, __nonce_value) := function_parameter in
                      logged_return
                        ((Item
                          ((Alpha_context.Internal_operation
                            {|
                              Alpha_context.internal_operation.source :=
                                step_constants.self step_constants;
                              Alpha_context.internal_operation.operation :=
                                operation;
                              Alpha_context.internal_operation.nonce :=
                                __nonce_value |}), None)
                          (Item (contract, "default") rest)), ctxt))))
        | (Script_typed_ir.Implicit_account, Item key rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.implicit_account))
            (fun ctxt =>
              let contract := Alpha_context.Contract.implicit_contract key in
              logged_return
                ((Item ((Script_typed_ir.Unit_t None), (contract, "default"))
                  rest), ctxt))
        |
          (Script_typed_ir.Create_contract storage_type param_type
            (Script_typed_ir.Lam _ code) root_name,
            Item manager
              (Item delegate
                (Item spendable
                  (Item delegatable (Item credit (Item init rest)))))) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.create_contract))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (Script_ir_translator.unparse_ty ctxt param_type)
                (fun function_parameter =>
                  let '(unparsed_param_type, ctxt) := function_parameter in
                  let unparsed_param_type :=
                    Script_ir_translator.add_field_annot
                      (Option.map
                        (fun n =>
                          (* ❌ Variants not supported *)
                          (* ❌ `Field_annot *)
                          Field_annot n) root_name) None unparsed_param_type in
                  Error_monad.op_gtgteqquestion
                    (Script_ir_translator.unparse_ty ctxt storage_type)
                    (fun function_parameter =>
                      let '(unparsed_storage_type, ctxt) := function_parameter
                        in
                      let code :=
                        Pervasives.op_atat
                          Alpha_context.Script.__lazy_expr_value
                          (Micheline.strip_locations
                            (Micheline.Seq 0
                              [
                                Micheline.Prim 0
                                  Alpha_context.Script.K_parameter
                                  [
                                    unparsed_param_type
                                  ] [];
                                Micheline.Prim 0 Alpha_context.Script.K_storage
                                  [
                                    unparsed_storage_type
                                  ] [];
                                Micheline.Prim 0 Alpha_context.Script.K_code
                                  [ code ] []
                              ])) in
                      Error_monad.op_gtgteqquestion
                        (Script_ir_translator.collect_big_maps ctxt storage_type
                          init)
                        (fun function_parameter =>
                          let '(to_duplicate, ctxt) := function_parameter in
                          let to_update := Script_ir_translator.no_big_map_id in
                          Error_monad.op_gtgteqquestion
                            (Script_ir_translator.extract_big_map_diff ctxt
                              Script_ir_translator.Optimized true to_duplicate
                              to_update storage_type init)
                            (fun function_parameter =>
                              let '(init, big_map_diff, ctxt) :=
                                function_parameter in
                              Error_monad.op_gtgteqquestion
                                (Script_ir_translator.unparse_data ctxt
                                  Script_ir_translator.Optimized storage_type
                                  init)
                                (fun function_parameter =>
                                  let '(storage, ctxt) := function_parameter in
                                  let storage :=
                                    Pervasives.op_atat
                                      Alpha_context.Script.__lazy_expr_value
                                      (Micheline.strip_locations storage) in
                                  Error_monad.op_gtgteqquestion
                                    (if spendable then
                                      Alpha_context.Script.Legacy_support.add_do
                                        manager code storage
                                    else
                                      if delegatable then
                                        Alpha_context.Script.Legacy_support.add_set_delegate
                                          manager code storage
                                      else
                                        if
                                          Alpha_context.Script.Legacy_support.has_default_entrypoint
                                            code then
                                          Error_monad.op_gtgteqquestion
                                            (Alpha_context.Script.Legacy_support.add_root_entrypoint
                                              code)
                                            (fun code =>
                                              Error_monad.__return
                                                (code, storage))
                                        else
                                          Error_monad.__return (code, storage))
                                    (fun function_parameter =>
                                      let '(code, storage) := function_parameter
                                        in
                                      Error_monad.op_gtgteqquestion
                                        (Alpha_context.Contract.fresh_contract_from_current_nonce
                                          ctxt)
                                        (fun function_parameter =>
                                          let '(ctxt, contract) :=
                                            function_parameter in
                                          let operation :=
                                            Alpha_context.Origination
                                              {|
                                                Alpha_context.manager_operation.Origination.delegate :=
                                                  delegate;
                                                Alpha_context.manager_operation.Origination.script :=
                                                  {|
                                                    Alpha_context.Script.t.code :=
                                                      code;
                                                    Alpha_context.Script.t.storage :=
                                                      storage |};
                                                Alpha_context.manager_operation.Origination.credit :=
                                                  credit;
                                                Alpha_context.manager_operation.Origination.preorigination :=
                                                  Some contract |} in
                                          Error_monad.op_gtgteqquestion
                                            (Lwt.__return
                                              (Alpha_context.fresh_internal_nonce
                                                ctxt))
                                            (fun function_parameter =>
                                              let '(ctxt, __nonce_value) :=
                                                function_parameter in
                                              logged_return
                                                ((Item
                                                  ((Alpha_context.Internal_operation
                                                    {|
                                                      Alpha_context.internal_operation.source :=
                                                        step_constants.self
                                                          step_constants;
                                                      Alpha_context.internal_operation.operation :=
                                                        operation;
                                                      Alpha_context.internal_operation.nonce :=
                                                        __nonce_value |}),
                                                    big_map_diff)
                                                  (Item (contract, "default")
                                                    rest)), ctxt))))))))))
        |
          (Script_typed_ir.Create_contract_2 storage_type param_type
            (Script_typed_ir.Lam _ code) root_name,
            Item delegate (Item credit (Item init rest))) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.create_contract))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (Script_ir_translator.unparse_ty ctxt param_type)
                (fun function_parameter =>
                  let '(unparsed_param_type, ctxt) := function_parameter in
                  let unparsed_param_type :=
                    Script_ir_translator.add_field_annot
                      (Option.map
                        (fun n =>
                          (* ❌ Variants not supported *)
                          (* ❌ `Field_annot *)
                          Field_annot n) root_name) None unparsed_param_type in
                  Error_monad.op_gtgteqquestion
                    (Script_ir_translator.unparse_ty ctxt storage_type)
                    (fun function_parameter =>
                      let '(unparsed_storage_type, ctxt) := function_parameter
                        in
                      let code :=
                        Micheline.strip_locations
                          (Micheline.Seq 0
                            [
                              Micheline.Prim 0 Alpha_context.Script.K_parameter
                                [ unparsed_param_type ]
                                [];
                              Micheline.Prim 0 Alpha_context.Script.K_storage
                                [
                                  unparsed_storage_type
                                ] [];
                              Micheline.Prim 0 Alpha_context.Script.K_code
                                [ code ] []
                            ]) in
                      Error_monad.op_gtgteqquestion
                        (Script_ir_translator.collect_big_maps ctxt storage_type
                          init)
                        (fun function_parameter =>
                          let '(to_duplicate, ctxt) := function_parameter in
                          let to_update := Script_ir_translator.no_big_map_id in
                          Error_monad.op_gtgteqquestion
                            (Script_ir_translator.extract_big_map_diff ctxt
                              Script_ir_translator.Optimized true to_duplicate
                              to_update storage_type init)
                            (fun function_parameter =>
                              let '(init, big_map_diff, ctxt) :=
                                function_parameter in
                              Error_monad.op_gtgteqquestion
                                (Script_ir_translator.unparse_data ctxt
                                  Script_ir_translator.Optimized storage_type
                                  init)
                                (fun function_parameter =>
                                  let '(storage, ctxt) := function_parameter in
                                  let storage :=
                                    Micheline.strip_locations storage in
                                  Error_monad.op_gtgteqquestion
                                    (Alpha_context.Contract.fresh_contract_from_current_nonce
                                      ctxt)
                                    (fun function_parameter =>
                                      let '(ctxt, contract) :=
                                        function_parameter in
                                      let operation :=
                                        Alpha_context.Origination
                                          {|
                                            Alpha_context.manager_operation.Origination.delegate :=
                                              delegate;
                                            Alpha_context.manager_operation.Origination.script :=
                                              {|
                                                Alpha_context.Script.t.code :=
                                                  Alpha_context.Script.__lazy_expr_value
                                                    code;
                                                Alpha_context.Script.t.storage :=
                                                  Alpha_context.Script.__lazy_expr_value
                                                    storage |};
                                            Alpha_context.manager_operation.Origination.credit :=
                                              credit;
                                            Alpha_context.manager_operation.Origination.preorigination :=
                                              Some contract |} in
                                      Error_monad.op_gtgteqquestion
                                        (Lwt.__return
                                          (Alpha_context.fresh_internal_nonce
                                            ctxt))
                                        (fun function_parameter =>
                                          let '(ctxt, __nonce_value) :=
                                            function_parameter in
                                          logged_return
                                            ((Item
                                              ((Alpha_context.Internal_operation
                                                {|
                                                  Alpha_context.internal_operation.source :=
                                                    step_constants.self
                                                      step_constants;
                                                  Alpha_context.internal_operation.operation :=
                                                    operation;
                                                  Alpha_context.internal_operation.nonce :=
                                                    __nonce_value |}),
                                                big_map_diff)
                                              (Item (contract, "default") rest)),
                                              ctxt)))))))))
        | (Script_typed_ir.Set_delegate, Item delegate rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.create_account))
            (fun ctxt =>
              let operation := Alpha_context.Delegation delegate in
              Error_monad.op_gtgteqquestion
                (Lwt.__return (Alpha_context.fresh_internal_nonce ctxt))
                (fun function_parameter =>
                  let '(ctxt, __nonce_value) := function_parameter in
                  logged_return
                    ((Item
                      ((Alpha_context.Internal_operation
                        {|
                          Alpha_context.internal_operation.source :=
                            step_constants.self step_constants;
                          Alpha_context.internal_operation.operation :=
                            operation;
                          Alpha_context.internal_operation.nonce :=
                            __nonce_value |}), None) rest), ctxt)))
        | (Script_typed_ir.Balance, rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.balance))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (Alpha_context.Contract.get_balance ctxt
                  (step_constants.self step_constants))
                (fun balance => logged_return ((Item balance rest), ctxt)))
        | (Script_typed_ir.Now, rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.now))
            (fun ctxt =>
              let now := Alpha_context.Script_timestamp.now ctxt in
              logged_return ((Item now rest), ctxt))
        |
          (Script_typed_ir.Check_signature,
            Item key (Item signature (Item message rest))) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt
                (Interp_costs.check_signature key message)))
            (fun ctxt =>
              let res := Signature.check None key signature message in
              logged_return ((Item res rest), ctxt))
        | (Script_typed_ir.Hash_key, Item key rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.hash_key))
            (fun ctxt =>
              logged_return
                ((Item
                  ((|Signature.Public_key|).(S.SPublic_key.__hash_value) key)
                  rest), ctxt))
        | (Script_typed_ir.Blake2b, Item __bytes_value rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt
                (Interp_costs.hash_blake2b __bytes_value)))
            (fun ctxt =>
              let __hash_value := Raw_hashes.blake2b __bytes_value in
              logged_return ((Item __hash_value rest), ctxt))
        | (Script_typed_ir.Sha256, Item __bytes_value rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt
                (Interp_costs.hash_sha256 __bytes_value)))
            (fun ctxt =>
              let __hash_value := Raw_hashes.sha256 __bytes_value in
              logged_return ((Item __hash_value rest), ctxt))
        | (Script_typed_ir.Sha512, Item __bytes_value rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt
                (Interp_costs.hash_sha512 __bytes_value)))
            (fun ctxt =>
              let __hash_value := Raw_hashes.sha512 __bytes_value in
              logged_return ((Item __hash_value rest), ctxt))
        | (Script_typed_ir.Steps_to_quota, rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt Interp_costs.steps_to_quota))
            (fun ctxt =>
              let steps :=
                match Alpha_context.Gas.level ctxt with
                |
                  Alpha_context.Gas.Limited {|
                    Alpha_context.Gas.t.Limited.remaining := remaining |} =>
                  remaining
                | Alpha_context.Gas.Unaccounted => Z.of_string "99999999"
                end in
              logged_return
                ((Item
                  (Alpha_context.Script_int.abs
                    (Alpha_context.Script_int.of_zint steps)) rest), ctxt))
        | (Script_typed_ir.Source, rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.source))
            (fun ctxt =>
              logged_return
                ((Item ((step_constants.payer step_constants), "default") rest),
                  ctxt))
        | (Script_typed_ir.Sender, rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.source))
            (fun ctxt =>
              logged_return
                ((Item ((step_constants.source step_constants), "default") rest),
                  ctxt))
        | (Script_typed_ir.Self __t_value entrypoint, rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.self))
            (fun ctxt =>
              logged_return
                ((Item
                  (__t_value, ((step_constants.self step_constants), entrypoint))
                  rest), ctxt))
        | (Script_typed_ir.Amount, rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.amount))
            (fun ctxt =>
              logged_return
                ((Item (step_constants.amount step_constants) rest), ctxt))
        | (Script_typed_ir.Dig n n', stack) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt (Interp_costs.stack_n_op n)))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (interp_stack_prefix_preserving_operation
                  (fun function_parameter =>
                    let 'Item v rest := function_parameter in
                    Error_monad.__return (rest, v)) n' stack)
                (fun function_parameter =>
                  let '(aft, x) := function_parameter in
                  logged_return ((Item x aft), ctxt)))
        | (Script_typed_ir.Dug n n', Item v rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt (Interp_costs.stack_n_op n)))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (interp_stack_prefix_preserving_operation
                  (fun stk => Error_monad.__return ((Item v stk), tt)) n' rest)
                (fun function_parameter =>
                  let '(aft, _) := function_parameter in
                  logged_return (aft, ctxt)))
        | (Script_typed_ir.Dipn n n' b, stack) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt (Interp_costs.stack_n_op n)))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (interp_stack_prefix_preserving_operation
                  (fun stk =>
                    Error_monad.op_gtgteqquestion
                      (step log ctxt step_constants b stk)
                      (fun function_parameter =>
                        let '(res, ctxt') := function_parameter in
                        Error_monad.__return (res, ctxt'))) n' stack)
                (fun function_parameter =>
                  let '(aft, ctxt') := function_parameter in
                  logged_return (aft, ctxt')))
        | (Script_typed_ir.Dropn n n', stack) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt (Interp_costs.stack_n_op n)))
            (fun ctxt =>
              Error_monad.op_gtgteqquestion
                (interp_stack_prefix_preserving_operation
                  (fun stk => Error_monad.__return (stk, stk)) n' stack)
                (fun function_parameter =>
                  let '(_, rest) := function_parameter in
                  logged_return (rest, ctxt)))
        | (Script_typed_ir.ChainId, rest) =>
          Error_monad.op_gtgteqquestion
            (Lwt.__return (Alpha_context.Gas.consume ctxt Interp_costs.chain_id))
            (fun ctxt =>
              logged_return
                ((Item (step_constants.chain_id step_constants) rest), ctxt))
        end)

with interp {p r : Set}
  (log : option (Pervasives.ref execution_trace)) (ctxt : Alpha_context.context)
  (step_constants : step_constants)
  (function_parameter : Script_typed_ir.lambda p r) {struct log}
  : p -> Lwt.t (Error_monad.tzresult (r * Alpha_context.context)) :=
  let 'Script_typed_ir.Lam code _ := function_parameter in
  fun arg =>
    let stack := Item arg Empty in
    Error_monad.op_gtgteqquestion
      match log with
      | None => Error_monad.return_unit
      | Some log =>
        Error_monad.op_gtgteqquestion
          (Error_monad.trace extensible_type_value
            (unparse_stack ctxt (stack, (Script_typed_ir.descr.bef code))))
          (fun stack =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            (* ❌ instruction_sequence ";" *)
            Error_monad.return_unit)
      end
      (fun function_parameter =>
        let '_ := function_parameter in
        Error_monad.op_gtgteqquestion (step log ctxt step_constants code stack)
          (fun function_parameter =>
            let '(Item ret Empty, ctxt) := function_parameter in
            Error_monad.__return (ret, ctxt)))

with execute
  (log : option (Pervasives.ref execution_trace)) (ctxt : Alpha_context.context)
  (mode : Script_ir_translator.unparsing_mode) (step_constants : step_constants)
  (entrypoint : string) (unparsed_script : Alpha_context.Script.t)
  (arg : Alpha_context.Script.node) {struct log}
  : Lwt.t
    (Error_monad.tzresult
      (Alpha_context.Script.expr * list Alpha_context.packed_internal_operation
        * Alpha_context.context * option Alpha_context.Contract.big_map_diff)) :=
  Error_monad.op_gtgteqquestion
    (Script_ir_translator.parse_script None ctxt true unparsed_script)
    (fun function_parameter =>
      let
        '(Script_ir_translator.Ex_script {|
          Script_typed_ir.script.code := code;
            Script_typed_ir.script.arg_type := arg_type;
            Script_typed_ir.script.storage := storage;
            Script_typed_ir.script.storage_type := storage_type;
            Script_typed_ir.script.root_name := root_name
            |}, ctxt) := function_parameter in
      Error_monad.op_gtgteqquestion
        (Error_monad.trace extensible_type_value
          (Lwt.__return
            (Script_ir_translator.find_entrypoint arg_type root_name entrypoint)))
        (fun function_parameter =>
          let '(box, _) := function_parameter in
          Error_monad.op_gtgteqquestion
            (Error_monad.trace extensible_type_value
              (Script_ir_translator.parse_data None ctxt false arg_type
                (box arg)))
            (fun function_parameter =>
              let '(arg, ctxt) := function_parameter in
              Error_monad.op_gtgteqquestion
                (Alpha_context.Script.force_decode ctxt
                  (Alpha_context.Script.t.code unparsed_script))
                (fun function_parameter =>
                  let '(script_code, ctxt) := function_parameter in
                  Error_monad.op_gtgteqquestion
                    (Script_ir_translator.collect_big_maps ctxt arg_type arg)
                    (fun function_parameter =>
                      let '(to_duplicate, ctxt) := function_parameter in
                      Error_monad.op_gtgteqquestion
                        (Script_ir_translator.collect_big_maps ctxt storage_type
                          storage)
                        (fun function_parameter =>
                          let '(to_update, ctxt) := function_parameter in
                          Error_monad.op_gtgteqquestion
                            (Error_monad.trace extensible_type_value
                              (interp log ctxt step_constants code
                                (arg, storage)))
                            (fun function_parameter =>
                              let '((ops, storage), ctxt) := function_parameter
                                in
                              Error_monad.op_gtgteqquestion
                                (Script_ir_translator.extract_big_map_diff ctxt
                                  mode false to_duplicate to_update storage_type
                                  storage)
                                (fun function_parameter =>
                                  let '(storage, big_map_diff, ctxt) :=
                                    function_parameter in
                                  Error_monad.op_gtgteqquestion
                                    (Error_monad.trace extensible_type_value
                                      (Script_ir_translator.unparse_data ctxt
                                        mode storage_type storage))
                                    (fun function_parameter =>
                                      let '(storage, ctxt) := function_parameter
                                        in
                                      let '(ops, op_diffs) := List.split ops in
                                      let big_map_diff :=
                                        match
                                          List.flatten
                                            (List.map (Option.unopt [])
                                              (Pervasives.op_at op_diffs
                                                [ big_map_diff ])) with
                                        | [] => None
                                        | diff => Some diff
                                        end in
                                      Error_monad.__return
                                        ((Micheline.strip_locations storage),
                                          ops, ctxt, big_map_diff)))))))))).

Module execution_result.
  Record record := Build {
    ctxt : Alpha_context.context;
    storage : Alpha_context.Script.expr;
    big_map_diff : option Alpha_context.Contract.big_map_diff;
    operations : list Alpha_context.packed_internal_operation }.
  Definition with_ctxt ctxt (r : record) :=
    Build ctxt r.(storage) r.(big_map_diff) r.(operations).
  Definition with_storage storage (r : record) :=
    Build r.(ctxt) storage r.(big_map_diff) r.(operations).
  Definition with_big_map_diff big_map_diff (r : record) :=
    Build r.(ctxt) r.(storage) big_map_diff r.(operations).
  Definition with_operations operations (r : record) :=
    Build r.(ctxt) r.(storage) r.(big_map_diff) operations.
End execution_result.
Definition execution_result := execution_result.record.

Definition trace
  (ctxt : Alpha_context.context) (mode : Script_ir_translator.unparsing_mode)
  (step_constants : step_constants) (script : Alpha_context.Script.t)
  (entrypoint : string)
  (parameter : Micheline.canonical Alpha_context.Script.prim)
  : Lwt.t
    (Error_monad.tzresult
      (execution_result *
        list
          (Alpha_context.Script.location * Alpha_context.Gas.t *
            list (Alpha_context.Script.expr * option string)))) :=
  let log := Pervasives.__ref_value [] in
  Error_monad.op_gtgteqquestion
    (execute (Some log) ctxt mode step_constants entrypoint script
      (Micheline.root parameter))
    (fun function_parameter =>
      let '(storage, operations, ctxt, big_map_diff) := function_parameter in
      let trace := List.rev (Pervasives.op_exclamation log) in
      Error_monad.__return
        ({| execution_result.ctxt := ctxt; execution_result.storage := storage;
          execution_result.big_map_diff := big_map_diff;
          execution_result.operations := operations |}, trace)).

Definition execute
  (ctxt : Alpha_context.context) (mode : Script_ir_translator.unparsing_mode)
  (step_constants : step_constants) (script : Alpha_context.Script.t)
  (entrypoint : string)
  (parameter : Micheline.canonical Alpha_context.Script.prim)
  : Lwt.t (Error_monad.tzresult execution_result) :=
  Error_monad.op_gtgteqquestion
    (execute None ctxt mode step_constants entrypoint script
      (Micheline.root parameter))
    (fun function_parameter =>
      let '(storage, operations, ctxt, big_map_diff) := function_parameter in
      Error_monad.__return
        {| execution_result.ctxt := ctxt; execution_result.storage := storage;
          execution_result.big_map_diff := big_map_diff;
          execution_result.operations := operations |}).

Script_interpreter_mli

  • OCaml size: 89 lines
  • Coq size: 96 lines (+7% compared to OCaml)
script_interpreter.mli 7 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

type execution_trace =
  (Script.location * Gas.t * (Script.expr * string option) list) list

type error +=
  | Reject of Script.location * Script.expr * execution_trace option

type error += Overflow of Script.location * execution_trace option

type error += Runtime_contract_error : Contract.t * Script.expr -> error

type error += Bad_contract_parameter of Contract.t (* `Permanent *)

type error += Cannot_serialize_log

type error += Cannot_serialize_failure

type error += Cannot_serialize_storage

type execution_result = {
  ctxt : context;
  storage : Script.expr;
  big_map_diff : Contract.big_map_diff option;
  operations : packed_internal_operation list;
}

type step_constants = {
  source : Contract.t;
  payer : Contract.t;
  self : Contract.t;
  amount : Tez.t;
  chain_id : Chain_id.t;
}

type 'tys stack =
  | Item : 'ty * 'rest stack -> ('ty * 'rest) stack
  | Empty : Script_typed_ir.end_of_stack stack

val step :
  ?log:execution_trace ref ->
  context ->
  step_constants ->
  ('bef, 'aft) Script_typed_ir.descr ->
  'bef stack ->
  ('aft stack * context) tzresult Lwt.t

val execute :
  Alpha_context.t ->
  Script_ir_translator.unparsing_mode ->
  step_constants ->
  script:Script.t ->
  entrypoint:string ->
  parameter:Script.expr ->
  execution_result tzresult Lwt.t

val trace :
  Alpha_context.t ->
  Script_ir_translator.unparsing_mode ->
  step_constants ->
  script:Script.t ->
  entrypoint:string ->
  parameter:Script.expr ->
  (execution_result * execution_trace) tzresult Lwt.t
Script_interpreter_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Script_ir_translator.
Require Tezos.Script_typed_ir.

Definition execution_trace :=
  list
    (Alpha_context.Script.location * Alpha_context.Gas.t *
      list (Alpha_context.Script.expr * option string)).

(* extensible_type error *)

(* extensible_type error *)

(* extensible_type error *)

(* extensible_type error *)

(* extensible_type error *)

(* extensible_type error *)

(* extensible_type error *)

Module execution_result.
  Record record := Build {
    ctxt : Alpha_context.context;
    storage : Alpha_context.Script.expr;
    big_map_diff : option Alpha_context.Contract.big_map_diff;
    operations : list Alpha_context.packed_internal_operation }.
  Definition with_ctxt ctxt (r : record) :=
    Build ctxt r.(storage) r.(big_map_diff) r.(operations).
  Definition with_storage storage (r : record) :=
    Build r.(ctxt) storage r.(big_map_diff) r.(operations).
  Definition with_big_map_diff big_map_diff (r : record) :=
    Build r.(ctxt) r.(storage) big_map_diff r.(operations).
  Definition with_operations operations (r : record) :=
    Build r.(ctxt) r.(storage) r.(big_map_diff) operations.
End execution_result.
Definition execution_result := execution_result.record.

Module step_constants.
  Record record := Build {
    source : Alpha_context.Contract.t;
    payer : Alpha_context.Contract.t;
    self : Alpha_context.Contract.t;
    amount : Alpha_context.Tez.t;
    chain_id : (|Chain_id|).(S.HASH.t) }.
  Definition with_source source (r : record) :=
    Build source r.(payer) r.(self) r.(amount) r.(chain_id).
  Definition with_payer payer (r : record) :=
    Build r.(source) payer r.(self) r.(amount) r.(chain_id).
  Definition with_self self (r : record) :=
    Build r.(source) r.(payer) self r.(amount) r.(chain_id).
  Definition with_amount amount (r : record) :=
    Build r.(source) r.(payer) r.(self) amount r.(chain_id).
  Definition with_chain_id chain_id (r : record) :=
    Build r.(source) r.(payer) r.(self) r.(amount) chain_id.
End step_constants.
Definition step_constants := step_constants.record.

Reserved Notation "'stack".

Inductive stack_gadt : Set :=
| Item : forall {ty : Set}, ty -> stack_gadt -> stack_gadt
| Empty : stack_gadt

where "'stack" := (fun (_ : Set) => stack_gadt).

Definition stack := 'stack.

Parameter step : forall {aft bef : Set},
  option (Pervasives.ref execution_trace) -> Alpha_context.context ->
  step_constants -> Script_typed_ir.descr bef aft -> stack bef ->
  Lwt.t (Error_monad.tzresult (stack aft * Alpha_context.context)).

Parameter execute :
  Alpha_context.t -> Script_ir_translator.unparsing_mode -> step_constants ->
  Alpha_context.Script.t -> string -> Alpha_context.Script.expr ->
  Lwt.t (Error_monad.tzresult execution_result).

Parameter trace :
  Alpha_context.t -> Script_ir_translator.unparsing_mode -> step_constants ->
  Alpha_context.Script.t -> string -> Alpha_context.Script.expr ->
  Lwt.t (Error_monad.tzresult (execution_result * execution_trace)).

Script_ir_annot

  • OCaml size: 521 lines
  • Coq size: 841 lines (+61% compared to OCaml)
script_ir_annot.ml 138 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Micheline
open Script_tc_errors
open Script_typed_ir

let default_now_annot = Some (`Var_annot "now")

let default_amount_annot = Some (`Var_annot "amount")

let default_balance_annot = Some (`Var_annot "balance")

let default_steps_annot = Some (`Var_annot "steps")

let default_source_annot = Some (`Var_annot "source")

let default_sender_annot = Some (`Var_annot "sender")

let default_self_annot = Some (`Var_annot "self")

let default_arg_annot = Some (`Var_annot "arg")

let default_param_annot = Some (`Var_annot "parameter")

let default_storage_annot = Some (`Var_annot "storage")

let default_car_annot = Some (`Field_annot "car")

let default_cdr_annot = Some (`Field_annot "cdr")

let default_contract_annot = Some (`Field_annot "contract")

let default_addr_annot = Some (`Field_annot "address")

let default_manager_annot = Some (`Field_annot "manager")

let default_pack_annot = Some (`Field_annot "packed")

let default_unpack_annot = Some (`Field_annot "unpacked")

let default_slice_annot = Some (`Field_annot "slice")

let default_elt_annot = Some (`Field_annot "elt")

let default_key_annot = Some (`Field_annot "key")

let default_hd_annot = Some (`Field_annot "hd")

let default_tl_annot = Some (`Field_annot "tl")

let default_some_annot = Some (`Field_annot "some")

let default_left_annot = Some (`Field_annot "left")

let default_right_annot = Some (`Field_annot "right")

let default_binding_annot = Some (`Field_annot "bnd")

let unparse_type_annot : type_annot option -> string list = function
  | None ->
      []
  | Some (`Type_annot a) ->
      [":" ^ a]

let unparse_var_annot : var_annot option -> string list = function
  | None ->
      []
  | Some (`Var_annot a) ->
      ["@" ^ a]

let unparse_field_annot : field_annot option -> string list = function
  | None ->
      []
  | Some (`Field_annot a) ->
      ["%" ^ a]

let field_to_var_annot : field_annot option -> var_annot option = function
  | None ->
      None
  | Some (`Field_annot s) ->
      Some (`Var_annot s)

let type_to_var_annot : type_annot option -> var_annot option = function
  | None ->
      None
  | Some (`Type_annot s) ->
      Some (`Var_annot s)

let var_to_field_annot : var_annot option -> field_annot option = function
  | None ->
      None
  | Some (`Var_annot s) ->
      Some (`Field_annot s)

let default_annot ~default = function None -> default | annot -> annot

let gen_access_annot :
    var_annot option ->
    ?default:field_annot option ->
    field_annot option ->
    var_annot option =
 fun value_annot ?(default = None) field_annot ->
  match (value_annot, field_annot, default) with
  | (None, None, _) | (Some _, None, None) | (None, Some (`Field_annot ""), _)
    ->
      None
  | (None, Some (`Field_annot f), _) ->
      Some (`Var_annot f)
  | ( Some (`Var_annot v),
      (None | Some (`Field_annot "")),
      Some (`Field_annot f) ) ->
      Some (`Var_annot (String.concat "." [v; f]))
  | (Some (`Var_annot v), Some (`Field_annot f), _) ->
      Some (`Var_annot (String.concat "." [v; f]))

let merge_type_annot :
    legacy:bool ->
    type_annot option ->
    type_annot option ->
    type_annot option tzresult =
 fun ~legacy annot1 annot2 ->
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) ->
      ok None
  | (Some (`Type_annot a1), Some (`Type_annot a2)) ->
      if legacy || String.equal a1 a2 then ok annot1
      else error (Inconsistent_annotations (":" ^ a1, ":" ^ a2))

let merge_field_annot :
    legacy:bool ->
    field_annot option ->
    field_annot option ->
    field_annot option tzresult =
 fun ~legacy annot1 annot2 ->
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) ->
      ok None
  | (Some (`Field_annot a1), Some (`Field_annot a2)) ->
      if legacy || String.equal a1 a2 then ok annot1
      else error (Inconsistent_annotations ("%" ^ a1, "%" ^ a2))

let merge_var_annot : var_annot option -> var_annot option -> var_annot option
    =
 fun annot1 annot2 ->
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) ->
      None
  | (Some (`Var_annot a1), Some (`Var_annot a2)) ->
      if String.equal a1 a2 then annot1 else None

let error_unexpected_annot loc annot =
  match annot with [] -> ok () | _ :: _ -> error (Unexpected_annotation loc)

let fail_unexpected_annot loc annot =
  Lwt.return (error_unexpected_annot loc annot)

let parse_annots loc ?(allow_special_var = false)
    ?(allow_special_field = false) l =
  (* allow emtpty annotations as wildcards but otherwise only accept
     annotations that start with [a-zA-Z_] *)
  let sub_or_wildcard ~specials wrap s acc =
    let len = String.length s in
    if Compare.Int.(len = 1) then ok @@ (wrap None :: acc)
    else
      match s.[1] with
      | 'a' .. 'z' | 'A' .. 'Z' | '_' ->
          ok @@ (wrap (Some (String.sub s 1 (len - 1))) :: acc)
      | '@' when Compare.Int.(len = 2) && List.mem '@' specials ->
          ok @@ (wrap (Some "@") :: acc)
      | '%' when List.mem '%' specials ->
          if Compare.Int.(len = 2) then ok @@ (wrap (Some "%") :: acc)
          else if Compare.Int.(len = 3) && Compare.Char.(s.[2] = '%') then
            ok @@ (wrap (Some "%%") :: acc)
          else error (Unexpected_annotation loc)
      | _ ->
          error (Unexpected_annotation loc)
  in
  List.fold_left
    (fun acc s ->
      acc
      >>? fun acc ->
      if Compare.Int.(String.length s = 0) then
        error (Unexpected_annotation loc)
      else
        match s.[0] with
        | ':' ->
            sub_or_wildcard ~specials:[] (fun a -> `Type_annot a) s acc
        | '@' ->
            sub_or_wildcard
              ~specials:(if allow_special_var then ['%'] else [])
              (fun a -> `Var_annot a)
              s
              acc
        | '%' ->
            sub_or_wildcard
              ~specials:(if allow_special_field then ['@'] else [])
              (fun a -> `Field_annot a)
              s
              acc
        | _ ->
            error (Unexpected_annotation loc))
    (ok [])
    l
  >|? List.rev

let opt_var_of_var_opt = function
  | `Var_annot None ->
      None
  | `Var_annot (Some a) ->
      Some (`Var_annot a)

let opt_field_of_field_opt = function
  | `Field_annot None ->
      None
  | `Field_annot (Some a) ->
      Some (`Field_annot a)

let opt_type_of_type_opt = function
  | `Type_annot None ->
      None
  | `Type_annot (Some a) ->
      Some (`Type_annot a)

let classify_annot loc l :
    (var_annot option list * type_annot option list * field_annot option list)
    tzresult =
  try
    let (_, rv, _, rt, _, rf) =
      List.fold_left
        (fun (in_v, rv, in_t, rt, in_f, rf) a ->
          match (a, in_v, rv, in_t, rt, in_f, rf) with
          | ((`Var_annot _ as a), true, _, _, _, _, _)
          | ((`Var_annot _ as a), false, [], _, _, _, _) ->
              (true, opt_var_of_var_opt a :: rv, false, rt, false, rf)
          | ((`Type_annot _ as a), _, _, true, _, _, _)
          | ((`Type_annot _ as a), _, _, false, [], _, _) ->
              (false, rv, true, opt_type_of_type_opt a :: rt, false, rf)
          | ((`Field_annot _ as a), _, _, _, _, true, _)
          | ((`Field_annot _ as a), _, _, _, _, false, []) ->
              (false, rv, false, rt, true, opt_field_of_field_opt a :: rf)
          | _ ->
              raise Exit)
        (false, [], false, [], false, [])
        l
    in
    ok (List.rev rv, List.rev rt, List.rev rf)
  with Exit -> error (Ungrouped_annotations loc)

let get_one_annot loc = function
  | [] ->
      ok None
  | [a] ->
      ok a
  | _ ->
      error (Unexpected_annotation loc)

let get_two_annot loc = function
  | [] ->
      ok (None, None)
  | [a] ->
      ok (a, None)
  | [a; b] ->
      ok (a, b)
  | _ ->
      error (Unexpected_annotation loc)

let parse_type_annot : int -> string list -> type_annot option tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc vars
  >>? fun () ->
  error_unexpected_annot loc fields >>? fun () -> get_one_annot loc types

let parse_type_field_annot :
    int -> string list -> (type_annot option * field_annot option) tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc vars
  >>? fun () ->
  get_one_annot loc types
  >>? fun t -> get_one_annot loc fields >|? fun f -> (t, f)

let parse_composed_type_annot :
    int ->
    string list ->
    (type_annot option * field_annot option * field_annot option) tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc vars
  >>? fun () ->
  get_one_annot loc types
  >>? fun t -> get_two_annot loc fields >|? fun (f1, f2) -> (t, f1, f2)

let parse_field_annot : int -> string list -> field_annot option tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc vars
  >>? fun () ->
  error_unexpected_annot loc types >>? fun () -> get_one_annot loc fields

let extract_field_annot :
    Script.node -> (Script.node * field_annot option) tzresult = function
  | Prim (loc, prim, args, annot) ->
      let rec extract_first acc = function
        | [] ->
            (None, annot)
        | s :: rest ->
            if Compare.Int.(String.length s > 0) && Compare.Char.(s.[0] = '%')
            then (Some s, List.rev_append acc rest)
            else extract_first (s :: acc) rest
      in
      let (field_annot, annot) = extract_first [] annot in
      let field_annot =
        match field_annot with
        | None ->
            None
        | Some field_annot ->
            Some
              (`Field_annot
                (String.sub field_annot 1 (String.length field_annot - 1)))
      in
      ok (Prim (loc, prim, args, annot), field_annot)
  | expr ->
      ok (expr, None)

let check_correct_field :
    field_annot option -> field_annot option -> unit tzresult =
 fun f1 f2 ->
  match (f1, f2) with
  | (None, _) | (_, None) ->
      ok ()
  | (Some (`Field_annot s1), Some (`Field_annot s2)) ->
      if String.equal s1 s2 then ok ()
      else error (Inconsistent_field_annotations ("%" ^ s1, "%" ^ s2))

let parse_var_annot :
    int ->
    ?default:var_annot option ->
    string list ->
    var_annot option tzresult =
 fun loc ?default annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc types
  >>? fun () ->
  error_unexpected_annot loc fields
  >>? fun () ->
  get_one_annot loc vars
  >|? function
  | Some _ as a ->
      a
  | None -> (
    match default with Some a -> a | None -> None )

let split_last_dot = function
  | None ->
      (None, None)
  | Some (`Field_annot s) -> (
    match String.rindex_opt s '.' with
    | None ->
        (None, Some (`Field_annot s))
    | Some i ->
        let s1 = String.sub s 0 i in
        let s2 = String.sub s (i + 1) (String.length s - i - 1) in
        let f =
          if Compare.String.equal s2 "car" || Compare.String.equal s2 "cdr"
          then None
          else Some (`Field_annot s2)
        in
        (Some (`Var_annot s1), f) )

let common_prefix v1 v2 =
  match (v1, v2) with
  | (Some (`Var_annot s1), Some (`Var_annot s2))
    when Compare.String.equal s1 s2 ->
      v1
  | (Some _, None) ->
      v1
  | (None, Some _) ->
      v2
  | (_, _) ->
      None

let parse_constr_annot :
    int ->
    ?if_special_first:field_annot option ->
    ?if_special_second:field_annot option ->
    string list ->
    ( var_annot option
    * type_annot option
    * field_annot option
    * field_annot option )
    tzresult =
 fun loc ?if_special_first ?if_special_second annot ->
  parse_annots ~allow_special_field:true loc annot
  >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  get_one_annot loc vars
  >>? fun v ->
  get_one_annot loc types
  >>? fun t ->
  get_two_annot loc fields
  >>? fun (f1, f2) ->
  ( match (if_special_first, f1) with
  | (Some special_var, Some (`Field_annot "@")) ->
      ok (split_last_dot special_var)
  | (None, Some (`Field_annot "@")) ->
      error (Unexpected_annotation loc)
  | (_, _) ->
      ok (v, f1) )
  >>? fun (v1, f1) ->
  ( match (if_special_second, f2) with
  | (Some special_var, Some (`Field_annot "@")) ->
      ok (split_last_dot special_var)
  | (None, Some (`Field_annot "@")) ->
      error (Unexpected_annotation loc)
  | (_, _) ->
      ok (v, f2) )
  >|? fun (v2, f2) ->
  let v = match v with None -> common_prefix v1 v2 | Some _ -> v in
  (v, t, f1, f2)

let parse_two_var_annot :
    int -> string list -> (var_annot option * var_annot option) tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc types
  >>? fun () ->
  error_unexpected_annot loc fields >>? fun () -> get_two_annot loc vars

let parse_destr_annot :
    int ->
    string list ->
    default_accessor:field_annot option ->
    field_name:field_annot option ->
    pair_annot:var_annot option ->
    value_annot:var_annot option ->
    (var_annot option * field_annot option) tzresult =
 fun loc annot ~default_accessor ~field_name ~pair_annot ~value_annot ->
  parse_annots loc ~allow_special_var:true annot
  >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc types
  >>? fun () ->
  get_one_annot loc vars
  >>? fun v ->
  get_one_annot loc fields
  >|? fun f ->
  let default =
    gen_access_annot pair_annot field_name ~default:default_accessor
  in
  let v =
    match v with
    | Some (`Var_annot "%") ->
        field_to_var_annot field_name
    | Some (`Var_annot "%%") ->
        default
    | Some _ ->
        v
    | None ->
        value_annot
  in
  (v, f)

let parse_entrypoint_annot :
    int ->
    ?default:var_annot option ->
    string list ->
    (var_annot option * field_annot option) tzresult =
 fun loc ?default annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc types
  >>? fun () ->
  get_one_annot loc fields
  >>? fun f ->
  get_one_annot loc vars
  >|? function
  | Some _ as a ->
      (a, f)
  | None -> (
    match default with Some a -> (a, f) | None -> (None, f) )

let parse_var_type_annot :
    int -> string list -> (var_annot option * type_annot option) tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc fields
  >>? fun () ->
  get_one_annot loc vars
  >>? fun v -> get_one_annot loc types >|? fun t -> (v, t)
Script_ir_annot.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Script_typed_ir.

Import Alpha_context.

Import Micheline.

Import Script_tc_errors.

Import Script_typed_ir.

Definition default_now_annot : option (* `Var_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Var_annot *)
    (Var_annot "now").

Definition default_amount_annot : option (* `Var_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Var_annot *)
    (Var_annot "amount").

Definition default_balance_annot : option (* `Var_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Var_annot *)
    (Var_annot "balance").

Definition default_steps_annot : option (* `Var_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Var_annot *)
    (Var_annot "steps").

Definition default_source_annot : option (* `Var_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Var_annot *)
    (Var_annot "source").

Definition default_sender_annot : option (* `Var_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Var_annot *)
    (Var_annot "sender").

Definition default_self_annot : option (* `Var_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Var_annot *)
    (Var_annot "self").

Definition default_arg_annot : option (* `Var_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Var_annot *)
    (Var_annot "arg").

Definition default_param_annot : option (* `Var_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Var_annot *)
    (Var_annot "parameter").

Definition default_storage_annot : option (* `Var_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Var_annot *)
    (Var_annot "storage").

Definition default_car_annot : option (* `Field_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Field_annot *)
    (Field_annot "car").

Definition default_cdr_annot : option (* `Field_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Field_annot *)
    (Field_annot "cdr").

Definition default_contract_annot : option (* `Field_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Field_annot *)
    (Field_annot "contract").

Definition default_addr_annot : option (* `Field_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Field_annot *)
    (Field_annot "address").

Definition default_manager_annot : option (* `Field_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Field_annot *)
    (Field_annot "manager").

Definition default_pack_annot : option (* `Field_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Field_annot *)
    (Field_annot "packed").

Definition default_unpack_annot : option (* `Field_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Field_annot *)
    (Field_annot "unpacked").

Definition default_slice_annot : option (* `Field_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Field_annot *)
    (Field_annot "slice").

Definition default_elt_annot : option (* `Field_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Field_annot *)
    (Field_annot "elt").

Definition default_key_annot : option (* `Field_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Field_annot *)
    (Field_annot "key").

Definition default_hd_annot : option (* `Field_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Field_annot *)
    (Field_annot "hd").

Definition default_tl_annot : option (* `Field_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Field_annot *)
    (Field_annot "tl").

Definition default_some_annot : option (* `Field_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Field_annot *)
    (Field_annot "some").

Definition default_left_annot : option (* `Field_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Field_annot *)
    (Field_annot "left").

Definition default_right_annot : option (* `Field_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Field_annot *)
    (Field_annot "right").

Definition default_binding_annot : option (* `Field_annot *) string :=
  Some
    (* ❌ Variants not supported *)
    (* ❌ `Field_annot *)
    (Field_annot "bnd").

Definition unparse_type_annot
  (function_parameter : option Script_typed_ir.type_annot) : list string :=
  match function_parameter with
  | None => []
  | Some (Type_annot a) => [ Pervasives.op_caret ":" a ]
  end.

Definition unparse_var_annot
  (function_parameter : option Script_typed_ir.var_annot) : list string :=
  match function_parameter with
  | None => []
  | Some (Var_annot a) => [ Pervasives.op_caret "@" a ]
  end.

Definition unparse_field_annot
  (function_parameter : option Script_typed_ir.field_annot) : list string :=
  match function_parameter with
  | None => []
  | Some (Field_annot a) => [ Pervasives.op_caret "%" a ]
  end.

Definition field_to_var_annot
  (function_parameter : option Script_typed_ir.field_annot)
  : option Script_typed_ir.var_annot :=
  match function_parameter with
  | None => None
  | Some (Field_annot s) =>
    Some
      (* ❌ Variants not supported *)
      (* ❌ `Var_annot *)
      (Var_annot s)
  end.

Definition type_to_var_annot
  (function_parameter : option Script_typed_ir.type_annot)
  : option Script_typed_ir.var_annot :=
  match function_parameter with
  | None => None
  | Some (Type_annot s) =>
    Some
      (* ❌ Variants not supported *)
      (* ❌ `Var_annot *)
      (Var_annot s)
  end.

Definition var_to_field_annot
  (function_parameter : option Script_typed_ir.var_annot)
  : option Script_typed_ir.field_annot :=
  match function_parameter with
  | None => None
  | Some (Var_annot s) =>
    Some
      (* ❌ Variants not supported *)
      (* ❌ `Field_annot *)
      (Field_annot s)
  end.

Definition default_annot {A : Set}
  (default : option A) (function_parameter : option A) : option A :=
  match function_parameter with
  | None => default
  | annot => annot
  end.

Definition gen_access_annot
  (value_annot : option Script_typed_ir.var_annot)
  (op_staroptstar : option (option Script_typed_ir.field_annot))
  : option Script_typed_ir.field_annot -> option Script_typed_ir.var_annot :=
  let default :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => None
    end in
  fun field_annot =>
    match (value_annot, field_annot, default) with
    | (None, None, _) | (Some _, None, None) | (None, Some (Field_annot ""), _)
      => None
    | (None, Some (Field_annot f), _) =>
      Some
        (* ❌ Variants not supported *)
        (* ❌ `Var_annot *)
        (Var_annot f)
    | (Some (Var_annot v), None | Some (Field_annot ""), Some (Field_annot f))
      =>
      Some
        (* ❌ Variants not supported *)
        (* ❌ `Var_annot *)
        (Var_annot (String.concat "." [ v; f ]))
    | (Some (Var_annot v), Some (Field_annot f), _) =>
      Some
        (* ❌ Variants not supported *)
        (* ❌ `Var_annot *)
        (Var_annot (String.concat "." [ v; f ]))
    end.

Definition merge_type_annot
  (legacy : bool) (annot1 : option Script_typed_ir.type_annot)
  (annot2 : option Script_typed_ir.type_annot)
  : Error_monad.tzresult (option Script_typed_ir.type_annot) :=
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) => Error_monad.ok None
  | (Some (Type_annot a1), Some (Type_annot a2)) =>
    if Pervasives.op_pipepipe legacy (String.equal a1 a2) then
      Error_monad.ok annot1
    else
      Error_monad.__error_value extensible_type_value
  end.

Definition merge_field_annot
  (legacy : bool) (annot1 : option Script_typed_ir.field_annot)
  (annot2 : option Script_typed_ir.field_annot)
  : Error_monad.tzresult (option Script_typed_ir.field_annot) :=
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) => Error_monad.ok None
  | (Some (Field_annot a1), Some (Field_annot a2)) =>
    if Pervasives.op_pipepipe legacy (String.equal a1 a2) then
      Error_monad.ok annot1
    else
      Error_monad.__error_value extensible_type_value
  end.

Definition merge_var_annot
  (annot1 : option Script_typed_ir.var_annot)
  (annot2 : option Script_typed_ir.var_annot)
  : option Script_typed_ir.var_annot :=
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) => None
  | (Some (Var_annot a1), Some (Var_annot a2)) =>
    if String.equal a1 a2 then
      annot1
    else
      None
  end.

Definition error_unexpected_annot {A : Set}
  (loc : Alpha_context.Script.location) (annot : list A)
  : Error_monad.tzresult unit :=
  match annot with
  | [] => Error_monad.ok tt
  | cons _ _ => Error_monad.__error_value extensible_type_value
  end.

Definition fail_unexpected_annot {A : Set}
  (loc : Alpha_context.Script.location) (annot : list A)
  : Lwt.t (Error_monad.tzresult unit) :=
  Lwt.__return (error_unexpected_annot loc annot).

Definition parse_annots
  (loc : Alpha_context.Script.location) (op_staroptstar : option bool)
  : option bool -> list string ->
  Error_monad.tzresult (list (* `Field_annot *) (option string)) :=
  let allow_special_var :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun op_staroptstar =>
    let allow_special_field :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun l =>
      let sub_or_wildcard {A : Set}
        (specials : list ascii) (wrap : option string -> A) (s : string)
        (acc : list A) : Error_monad.tzresult (list A) :=
        let len := String.length s in
        if (|Compare.Int|).(Compare.S.op_eq) len 1 then
          Pervasives.op_atat Error_monad.ok (cons (wrap None) acc)
        else
          match
            ((String.get s 1),
              match String.get s 1 with
              | "@" % char =>
                Pervasives.op_andand ((|Compare.Int|).(Compare.S.op_eq) len 2)
                  (List.mem "@" % char specials)
              | _ => false
              end,
              match String.get s 1 with
              | "%" % char => List.mem "%" % char specials
              | _ => false
              end) with
          |
            ("a" % char | "b" % char | "c" % char | "d" % char | "e" % char |
            "f" % char | "g" % char | "h" % char | "i" % char | "j" % char |
            "k" % char | "l" % char | "m" % char | "n" % char | "o" % char |
            "p" % char | "q" % char | "r" % char | "s" % char | "t" % char |
            "u" % char | "v" % char | "w" % char | "x" % char | "y" % char |
            "z" % char | "A" % char | "B" % char | "C" % char | "D" % char |
            "E" % char | "F" % char | "G" % char | "H" % char | "I" % char |
            "J" % char | "K" % char | "L" % char | "M" % char | "N" % char |
            "O" % char | "P" % char | "Q" % char | "R" % char | "S" % char |
            "T" % char | "U" % char | "V" % char | "W" % char | "X" % char |
            "Y" % char | "Z" % char | "_" % char, _, _) =>
            Pervasives.op_atat Error_monad.ok
              (cons (wrap (Some (String.sub s 1 (Pervasives.op_minus len 1))))
                acc)
          | ("@" % char, true, _) =>
            Pervasives.op_atat Error_monad.ok (cons (wrap (Some "@")) acc)
          | ("%" % char, _, true) =>
            if (|Compare.Int|).(Compare.S.op_eq) len 2 then
              Pervasives.op_atat Error_monad.ok (cons (wrap (Some "%")) acc)
            else
              if
                Pervasives.op_andand ((|Compare.Int|).(Compare.S.op_eq) len 3)
                  ((|Compare.Char|).(Compare.S.op_eq) (String.get s 2)
                    "%" % char) then
                Pervasives.op_atat Error_monad.ok (cons (wrap (Some "%%")) acc)
              else
                Error_monad.__error_value extensible_type_value
          | (_, _, _) => Error_monad.__error_value extensible_type_value
          end in
      Error_monad.op_gtpipequestion
        (List.fold_left
          (fun acc =>
            fun s =>
              Error_monad.op_gtgtquestion acc
                (fun acc =>
                  if (|Compare.Int|).(Compare.S.op_eq) (String.length s) 0 then
                    Error_monad.__error_value extensible_type_value
                  else
                    match String.get s 0 with
                    | ":" % char =>
                      sub_or_wildcard []
                        (fun a =>
                          (* ❌ Variants not supported *)
                          (* ❌ `Type_annot *)
                          Type_annot a) s acc
                    | "@" % char =>
                      sub_or_wildcard
                        (if allow_special_var then
                          [ "%" % char ]
                        else
                          [])
                        (fun a =>
                          (* ❌ Variants not supported *)
                          (* ❌ `Var_annot *)
                          Var_annot a) s acc
                    | "%" % char =>
                      sub_or_wildcard
                        (if allow_special_field then
                          [ "@" % char ]
                        else
                          [])
                        (fun a =>
                          (* ❌ Variants not supported *)
                          (* ❌ `Field_annot *)
                          Field_annot a) s acc
                    | _ => Error_monad.__error_value extensible_type_value
                    end)) (Error_monad.ok []) l) List.rev.

Definition opt_var_of_var_opt {A : Set}
  (function_parameter : (* `Var_annot *) option A)
  : option (* `Var_annot *) A :=
  match function_parameter with
  | Var_annot None => None
  | Var_annot (Some a) =>
    Some
      (* ❌ Variants not supported *)
      (* ❌ `Var_annot *)
      (Var_annot a)
  end.

Definition opt_field_of_field_opt {A : Set}
  (function_parameter : (* `Field_annot *) option A)
  : option (* `Field_annot *) A :=
  match function_parameter with
  | Field_annot None => None
  | Field_annot (Some a) =>
    Some
      (* ❌ Variants not supported *)
      (* ❌ `Field_annot *)
      (Field_annot a)
  end.

Definition opt_type_of_type_opt {A : Set}
  (function_parameter : (* `Type_annot *) option A)
  : option (* `Type_annot *) A :=
  match function_parameter with
  | Type_annot None => None
  | Type_annot (Some a) =>
    Some
      (* ❌ Variants not supported *)
      (* ❌ `Type_annot *)
      (Type_annot a)
  end.

Definition classify_annot
  (loc : Alpha_context.Script.location)
  (l : list (* `Var_annot *) (option string))
  : Error_monad.tzresult
    (list (option Script_typed_ir.var_annot) *
      list (option Script_typed_ir.type_annot) *
      list (option Script_typed_ir.field_annot)) :=
  (* ❌ Try-with are not handled *)
  try
    (let '(_, rv, _, rt, _, rf) :=
      List.fold_left
        (fun function_parameter =>
          let '(in_v, rv, in_t, rt, in_f, rf) := function_parameter in
          fun a =>
            match (a, in_v, rv, in_t, rt, in_f, rf) with
            |
              ((Var_annot _) as a, true, _, _, _, _, _) |
              ((Var_annot _) as a, false, [], _, _, _, _) =>
              (true, (cons (opt_var_of_var_opt a) rv), false, rt, false, rf)
            |
              ((Type_annot _) as a, _, _, true, _, _, _) |
              ((Type_annot _) as a, _, _, false, [], _, _) =>
              (false, rv, true, (cons (opt_type_of_type_opt a) rt), false, rf)
            |
              ((Field_annot _) as a, _, _, _, _, true, _) |
              ((Field_annot _) as a, _, _, _, _, false, []) =>
              (false, rv, false, rt, true, (cons (opt_field_of_field_opt a) rf))
            | _ => Pervasives.raise extensible_type_value
            end) (false, [], false, [], false, []) l in
    Error_monad.ok ((List.rev rv), (List.rev rt), (List.rev rf))).

Definition get_one_annot {A : Set}
  (loc : Alpha_context.Script.location) (function_parameter : list (option A))
  : Error_monad.tzresult (option A) :=
  match function_parameter with
  | [] => Error_monad.ok None
  | cons a [] => Error_monad.ok a
  | _ => Error_monad.__error_value extensible_type_value
  end.

Definition get_two_annot {A : Set}
  (loc : Alpha_context.Script.location) (function_parameter : list (option A))
  : Error_monad.tzresult (option A * option A) :=
  match function_parameter with
  | [] => Error_monad.ok (None, None)
  | cons a [] => Error_monad.ok (a, None)
  | cons a (cons b []) => Error_monad.ok (a, b)
  | _ => Error_monad.__error_value extensible_type_value
  end.

Definition parse_type_annot (loc : Z) (annot : list string)
  : Error_monad.tzresult (option Script_typed_ir.type_annot) :=
  Error_monad.op_gtgtquestion
    (Error_monad.op_gtgtquestion (parse_annots loc None None annot)
      (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      Error_monad.op_gtgtquestion (error_unexpected_annot loc vars)
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgtquestion (error_unexpected_annot loc fields)
            (fun function_parameter =>
              let '_ := function_parameter in
              get_one_annot loc types))).

Definition parse_type_field_annot (loc : Z) (annot : list string)
  : Error_monad.tzresult
    (option Script_typed_ir.type_annot * option Script_typed_ir.field_annot) :=
  Error_monad.op_gtgtquestion
    (Error_monad.op_gtgtquestion (parse_annots loc None None annot)
      (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      Error_monad.op_gtgtquestion (error_unexpected_annot loc vars)
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgtquestion (get_one_annot loc types)
            (fun __t_value =>
              Error_monad.op_gtpipequestion (get_one_annot loc fields)
                (fun f => (__t_value, f))))).

Definition parse_composed_type_annot (loc : Z) (annot : list string)
  : Error_monad.tzresult
    (option Script_typed_ir.type_annot * option Script_typed_ir.field_annot *
      option Script_typed_ir.field_annot) :=
  Error_monad.op_gtgtquestion
    (Error_monad.op_gtgtquestion (parse_annots loc None None annot)
      (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      Error_monad.op_gtgtquestion (error_unexpected_annot loc vars)
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgtquestion (get_one_annot loc types)
            (fun __t_value =>
              Error_monad.op_gtpipequestion (get_two_annot loc fields)
                (fun function_parameter =>
                  let '(f1, f2) := function_parameter in
                  (__t_value, f1, f2))))).

Definition parse_field_annot (loc : Z) (annot : list string)
  : Error_monad.tzresult (option Script_typed_ir.field_annot) :=
  Error_monad.op_gtgtquestion
    (Error_monad.op_gtgtquestion (parse_annots loc None None annot)
      (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      Error_monad.op_gtgtquestion (error_unexpected_annot loc vars)
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgtquestion (error_unexpected_annot loc types)
            (fun function_parameter =>
              let '_ := function_parameter in
              get_one_annot loc fields))).

Definition extract_field_annot (function_parameter : Alpha_context.Script.node)
  : Error_monad.tzresult
    (Alpha_context.Script.node * option Script_typed_ir.field_annot) :=
  match function_parameter with
  | Micheline.Prim loc prim args annot =>
    let fix extract_first (acc : list string) (function_parameter : list string)
      {struct acc} : option string * Micheline.annot :=
      match function_parameter with
      | [] => (None, annot)
      | cons s rest =>
        if
          Pervasives.op_andand
            ((|Compare.Int|).(Compare.S.op_gt) (String.length s) 0)
            ((|Compare.Char|).(Compare.S.op_eq) (String.get s 0) "%" % char)
          then
          ((Some s), (List.rev_append acc rest))
        else
          extract_first (cons s acc) rest
      end in
    let '(field_annot, annot) := extract_first [] annot in
    let field_annot :=
      match field_annot with
      | None => None
      | Some field_annot =>
        Some
          (* ❌ Variants not supported *)
          (* ❌ `Field_annot *)
          (Field_annot
            (String.sub field_annot 1
              (Pervasives.op_minus (String.length field_annot) 1)))
      end in
    Error_monad.ok ((Micheline.Prim loc prim args annot), field_annot)
  | expr => Error_monad.ok (expr, None)
  end.

Definition check_correct_field
  (f1 : option Script_typed_ir.field_annot)
  (f2 : option Script_typed_ir.field_annot) : Error_monad.tzresult unit :=
  match (f1, f2) with
  | (None, _) | (_, None) => Error_monad.ok tt
  | (Some (Field_annot s1), Some (Field_annot s2)) =>
    if String.equal s1 s2 then
      Error_monad.ok tt
    else
      Error_monad.__error_value extensible_type_value
  end.

Definition parse_var_annot
  (loc : Z) (default : option (option Script_typed_ir.var_annot))
  (annot : list string)
  : Error_monad.tzresult (option Script_typed_ir.var_annot) :=
  Error_monad.op_gtgtquestion
    (Error_monad.op_gtgtquestion (parse_annots loc None None annot)
      (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      Error_monad.op_gtgtquestion (error_unexpected_annot loc types)
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgtquestion (error_unexpected_annot loc fields)
            (fun function_parameter =>
              let '_ := function_parameter in
              Error_monad.op_gtpipequestion (get_one_annot loc vars)
                (fun function_parameter =>
                  match function_parameter with
                  | (Some _) as a => a
                  | None =>
                    match default with
                    | Some a => a
                    | None => None
                    end
                  end)))).

Definition split_last_dot
  (function_parameter : option (* `Field_annot *) string)
  : option (* `Var_annot *) string * option (* `Field_annot *) string :=
  match function_parameter with
  | None => (None, None)
  | Some (Field_annot s) =>
    match String.rindex_opt s "." % char with
    | None =>
      (None,
        (Some
          (* ❌ Variants not supported *)
          (* ❌ `Field_annot *)
          (Field_annot s)))
    | Some i =>
      let s1 := String.sub s 0 i in
      let s2 :=
        String.sub s (Pervasives.op_plus i 1)
          (Pervasives.op_minus (Pervasives.op_minus (String.length s) i) 1) in
      let f :=
        if
          Pervasives.op_pipepipe ((|Compare.String|).(Compare.S.equal) s2 "car")
            ((|Compare.String|).(Compare.S.equal) s2 "cdr") then
          None
        else
          Some
            (* ❌ Variants not supported *)
            (* ❌ `Field_annot *)
            (Field_annot s2) in
      ((Some
        (* ❌ Variants not supported *)
        (* ❌ `Var_annot *)
        (Var_annot s1)), f)
    end
  end.

Definition common_prefix
  (v1 : option (* `Var_annot *) (|Compare.String|).(Compare.S.t))
  (v2 : option (* `Var_annot *) (|Compare.String|).(Compare.S.t))
  : option (* `Var_annot *) (|Compare.String|).(Compare.S.t) :=
  match
    ((v1, v2),
      match (v1, v2) with
      | (Some (Var_annot s1), Some (Var_annot s2)) =>
        (|Compare.String|).(Compare.S.equal) s1 s2
      | _ => false
      end) with
  | ((Some (Var_annot s1), Some (Var_annot s2)), true) => v1
  | ((Some _, None), _) => v1
  | ((None, Some _), _) => v2
  | ((_, _), _) => None
  end.

Definition parse_constr_annot
  (loc : Z) (if_special_first : option (option Script_typed_ir.field_annot))
  (if_special_second : option (option Script_typed_ir.field_annot))
  (annot : list string)
  : Error_monad.tzresult
    (option Script_typed_ir.var_annot * option Script_typed_ir.type_annot *
      option Script_typed_ir.field_annot * option Script_typed_ir.field_annot) :=
  Error_monad.op_gtgtquestion
    (Error_monad.op_gtgtquestion (parse_annots loc None (Some true) annot)
      (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      Error_monad.op_gtgtquestion (get_one_annot loc vars)
        (fun v =>
          Error_monad.op_gtgtquestion (get_one_annot loc types)
            (fun __t_value =>
              Error_monad.op_gtgtquestion (get_two_annot loc fields)
                (fun function_parameter =>
                  let '(f1, f2) := function_parameter in
                  Error_monad.op_gtgtquestion
                    match (if_special_first, f1) with
                    | (Some special_var, Some (Field_annot "@")) =>
                      Error_monad.ok (split_last_dot special_var)
                    | (None, Some (Field_annot "@")) =>
                      Error_monad.__error_value extensible_type_value
                    | (_, _) => Error_monad.ok (v, f1)
                    end
                    (fun function_parameter =>
                      let '(v1, f1) := function_parameter in
                      Error_monad.op_gtpipequestion
                        match (if_special_second, f2) with
                        | (Some special_var, Some (Field_annot "@")) =>
                          Error_monad.ok (split_last_dot special_var)
                        | (None, Some (Field_annot "@")) =>
                          Error_monad.__error_value extensible_type_value
                        | (_, _) => Error_monad.ok (v, f2)
                        end
                        (fun function_parameter =>
                          let '(v2, f2) := function_parameter in
                          let v :=
                            match v with
                            | None => common_prefix v1 v2
                            | Some _ => v
                            end in
                          (v, __t_value, f1, f2))))))).

Definition parse_two_var_annot (loc : Z) (annot : list string)
  : Error_monad.tzresult
    (option Script_typed_ir.var_annot * option Script_typed_ir.var_annot) :=
  Error_monad.op_gtgtquestion
    (Error_monad.op_gtgtquestion (parse_annots loc None None annot)
      (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      Error_monad.op_gtgtquestion (error_unexpected_annot loc types)
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgtquestion (error_unexpected_annot loc fields)
            (fun function_parameter =>
              let '_ := function_parameter in
              get_two_annot loc vars))).

Definition parse_destr_annot
  (loc : Z) (annot : list string)
  (default_accessor : option Script_typed_ir.field_annot)
  (field_name : option Script_typed_ir.field_annot)
  (pair_annot : option Script_typed_ir.var_annot)
  (value_annot : option Script_typed_ir.var_annot)
  : Error_monad.tzresult
    (option Script_typed_ir.var_annot * option Script_typed_ir.field_annot) :=
  Error_monad.op_gtgtquestion
    (Error_monad.op_gtgtquestion (parse_annots loc (Some true) None annot)
      (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      Error_monad.op_gtgtquestion (error_unexpected_annot loc types)
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgtquestion (get_one_annot loc vars)
            (fun v =>
              Error_monad.op_gtpipequestion (get_one_annot loc fields)
                (fun f =>
                  let default :=
                    gen_access_annot pair_annot (Some default_accessor)
                      field_name in
                  let v :=
                    match v with
                    | Some (Var_annot "%") => field_to_var_annot field_name
                    | Some (Var_annot "%%") => default
                    | Some _ => v
                    | None => value_annot
                    end in
                  (v, f))))).

Definition parse_entrypoint_annot
  (loc : Z) (default : option (option Script_typed_ir.var_annot))
  (annot : list string)
  : Error_monad.tzresult
    (option Script_typed_ir.var_annot * option Script_typed_ir.field_annot) :=
  Error_monad.op_gtgtquestion
    (Error_monad.op_gtgtquestion (parse_annots loc None None annot)
      (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      Error_monad.op_gtgtquestion (error_unexpected_annot loc types)
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgtquestion (get_one_annot loc fields)
            (fun f =>
              Error_monad.op_gtpipequestion (get_one_annot loc vars)
                (fun function_parameter =>
                  match function_parameter with
                  | (Some _) as a => (a, f)
                  | None =>
                    match default with
                    | Some a => (a, f)
                    | None => (None, f)
                    end
                  end)))).

Definition parse_var_type_annot (loc : Z) (annot : list string)
  : Error_monad.tzresult
    (option Script_typed_ir.var_annot * option Script_typed_ir.type_annot) :=
  Error_monad.op_gtgtquestion
    (Error_monad.op_gtgtquestion (parse_annots loc None None annot)
      (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      Error_monad.op_gtgtquestion (error_unexpected_annot loc fields)
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgtquestion (get_one_annot loc vars)
            (fun v =>
              Error_monad.op_gtpipequestion (get_one_annot loc types)
                (fun __t_value => (v, __t_value))))).

Script_ir_annot_mli

  • OCaml size: 198 lines
  • Coq size: 168 lines (-16% compared to OCaml)
script_ir_annot.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Script_typed_ir

(** Default annotations *)

val default_now_annot : var_annot option

val default_amount_annot : var_annot option

val default_balance_annot : var_annot option

val default_steps_annot : var_annot option

val default_source_annot : var_annot option

val default_sender_annot : var_annot option

val default_self_annot : var_annot option

val default_arg_annot : var_annot option

val default_param_annot : var_annot option

val default_storage_annot : var_annot option

val default_car_annot : field_annot option

val default_cdr_annot : field_annot option

val default_contract_annot : field_annot option

val default_addr_annot : field_annot option

val default_manager_annot : field_annot option

val default_pack_annot : field_annot option

val default_unpack_annot : field_annot option

val default_slice_annot : field_annot option

val default_elt_annot : field_annot option

val default_key_annot : field_annot option

val default_hd_annot : field_annot option

val default_tl_annot : field_annot option

val default_some_annot : field_annot option

val default_left_annot : field_annot option

val default_right_annot : field_annot option

val default_binding_annot : field_annot option

(** Unparse annotations to their string representation *)

val unparse_type_annot : type_annot option -> string list

val unparse_var_annot : var_annot option -> string list

val unparse_field_annot : field_annot option -> string list

(** Convertions functions between different annotation kinds *)

val field_to_var_annot : field_annot option -> var_annot option

val type_to_var_annot : type_annot option -> var_annot option

val var_to_field_annot : var_annot option -> field_annot option

(** Replace an annotation by its default value if it is [None] *)
val default_annot : default:'a option -> 'a option -> 'a option

(** Generate annotation for field accesses, of the form [var.field1.field2] *)
val gen_access_annot :
  var_annot option ->
  ?default:field_annot option ->
  field_annot option ->
  var_annot option

(** Merge type annotations.
    @return an error {!Inconsistent_type_annotations} if they are both present
    and different, unless [legacy] *)
val merge_type_annot :
  legacy:bool ->
  type_annot option ->
  type_annot option ->
  type_annot option tzresult

(** Merge field annotations.
    @return an error {!Inconsistent_type_annotations} if they are both present
    and different, unless [legacy] *)
val merge_field_annot :
  legacy:bool ->
  field_annot option ->
  field_annot option ->
  field_annot option tzresult

(** Merge variable annotations, does not fail ([None] if different). *)
val merge_var_annot : var_annot option -> var_annot option -> var_annot option

(** @return an error {!Unexpected_annotation} in the monad the list is not empty. *)
val error_unexpected_annot : int -> 'a list -> unit tzresult

(** Same as {!error_unexpected_annot} in Lwt. *)
val fail_unexpected_annot : int -> 'a list -> unit tzresult Lwt.t

(** Parse a type annotation only. *)
val parse_type_annot : int -> string list -> type_annot option tzresult

(** Parse a field annotation only. *)
val parse_field_annot : int -> string list -> field_annot option tzresult

(** Parse an annotation for composed types, of the form
    [:ty_name %field] in any order. *)
val parse_type_field_annot :
  int -> string list -> (type_annot option * field_annot option) tzresult

(** Parse an annotation for composed types, of the form
    [:ty_name %field1 %field2] in any order. *)
val parse_composed_type_annot :
  int ->
  string list ->
  (type_annot option * field_annot option * field_annot option) tzresult

(** Extract and remove a field annotation from a node *)
val extract_field_annot :
  Script.node -> (Script.node * field_annot option) tzresult

(** Check that field annotations match, used for field accesses. *)
val check_correct_field :
  field_annot option -> field_annot option -> unit tzresult

(** Instruction annotations parsing *)

(** Parse a variable annotation, replaced by a default value if [None]. *)
val parse_var_annot :
  int -> ?default:var_annot option -> string list -> var_annot option tzresult

val parse_constr_annot :
  int ->
  ?if_special_first:field_annot option ->
  ?if_special_second:field_annot option ->
  string list ->
  ( var_annot option
  * type_annot option
  * field_annot option
  * field_annot option )
  tzresult

val parse_two_var_annot :
  int -> string list -> (var_annot option * var_annot option) tzresult

val parse_destr_annot :
  int ->
  string list ->
  default_accessor:field_annot option ->
  field_name:field_annot option ->
  pair_annot:var_annot option ->
  value_annot:var_annot option ->
  (var_annot option * field_annot option) tzresult

val parse_entrypoint_annot :
  int ->
  ?default:var_annot option ->
  string list ->
  (var_annot option * field_annot option) tzresult

val parse_var_type_annot :
  int -> string list -> (var_annot option * type_annot option) tzresult
Script_ir_annot_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Script_typed_ir.

Parameter default_now_annot : option Script_typed_ir.var_annot.

Parameter default_amount_annot : option Script_typed_ir.var_annot.

Parameter default_balance_annot : option Script_typed_ir.var_annot.

Parameter default_steps_annot : option Script_typed_ir.var_annot.

Parameter default_source_annot : option Script_typed_ir.var_annot.

Parameter default_sender_annot : option Script_typed_ir.var_annot.

Parameter default_self_annot : option Script_typed_ir.var_annot.

Parameter default_arg_annot : option Script_typed_ir.var_annot.

Parameter default_param_annot : option Script_typed_ir.var_annot.

Parameter default_storage_annot : option Script_typed_ir.var_annot.

Parameter default_car_annot : option Script_typed_ir.field_annot.

Parameter default_cdr_annot : option Script_typed_ir.field_annot.

Parameter default_contract_annot : option Script_typed_ir.field_annot.

Parameter default_addr_annot : option Script_typed_ir.field_annot.

Parameter default_manager_annot : option Script_typed_ir.field_annot.

Parameter default_pack_annot : option Script_typed_ir.field_annot.

Parameter default_unpack_annot : option Script_typed_ir.field_annot.

Parameter default_slice_annot : option Script_typed_ir.field_annot.

Parameter default_elt_annot : option Script_typed_ir.field_annot.

Parameter default_key_annot : option Script_typed_ir.field_annot.

Parameter default_hd_annot : option Script_typed_ir.field_annot.

Parameter default_tl_annot : option Script_typed_ir.field_annot.

Parameter default_some_annot : option Script_typed_ir.field_annot.

Parameter default_left_annot : option Script_typed_ir.field_annot.

Parameter default_right_annot : option Script_typed_ir.field_annot.

Parameter default_binding_annot : option Script_typed_ir.field_annot.

Parameter unparse_type_annot : option Script_typed_ir.type_annot -> list string.

Parameter unparse_var_annot : option Script_typed_ir.var_annot -> list string.

Parameter unparse_field_annot :
  option Script_typed_ir.field_annot -> list string.

Parameter field_to_var_annot :
  option Script_typed_ir.field_annot -> option Script_typed_ir.var_annot.

Parameter type_to_var_annot :
  option Script_typed_ir.type_annot -> option Script_typed_ir.var_annot.

Parameter var_to_field_annot :
  option Script_typed_ir.var_annot -> option Script_typed_ir.field_annot.

Parameter default_annot : forall {a : Set}, option a -> option a -> option a.

Parameter gen_access_annot :
  option Script_typed_ir.var_annot ->
  option (option Script_typed_ir.field_annot) ->
  option Script_typed_ir.field_annot -> option Script_typed_ir.var_annot.

Parameter merge_type_annot :
  bool -> option Script_typed_ir.type_annot ->
  option Script_typed_ir.type_annot ->
  Error_monad.tzresult (option Script_typed_ir.type_annot).

Parameter merge_field_annot :
  bool -> option Script_typed_ir.field_annot ->
  option Script_typed_ir.field_annot ->
  Error_monad.tzresult (option Script_typed_ir.field_annot).

Parameter merge_var_annot :
  option Script_typed_ir.var_annot -> option Script_typed_ir.var_annot ->
  option Script_typed_ir.var_annot.

Parameter error_unexpected_annot : forall {a : Set},
  Z -> list a -> Error_monad.tzresult unit.

Parameter fail_unexpected_annot : forall {a : Set},
  Z -> list a -> Lwt.t (Error_monad.tzresult unit).

Parameter parse_type_annot :
  Z -> list string -> Error_monad.tzresult (option Script_typed_ir.type_annot).

Parameter parse_field_annot :
  Z -> list string -> Error_monad.tzresult (option Script_typed_ir.field_annot).

Parameter parse_type_field_annot :
  Z -> list string ->
  Error_monad.tzresult
    (option Script_typed_ir.type_annot * option Script_typed_ir.field_annot).

Parameter parse_composed_type_annot :
  Z -> list string ->
  Error_monad.tzresult
    (option Script_typed_ir.type_annot * option Script_typed_ir.field_annot *
      option Script_typed_ir.field_annot).

Parameter extract_field_annot :
  Alpha_context.Script.node ->
  Error_monad.tzresult
    (Alpha_context.Script.node * option Script_typed_ir.field_annot).

Parameter check_correct_field :
  option Script_typed_ir.field_annot -> option Script_typed_ir.field_annot ->
  Error_monad.tzresult unit.

Parameter parse_var_annot :
  Z -> option (option Script_typed_ir.var_annot) -> list string ->
  Error_monad.tzresult (option Script_typed_ir.var_annot).

Parameter parse_constr_annot :
  Z -> option (option Script_typed_ir.field_annot) ->
  option (option Script_typed_ir.field_annot) -> list string ->
  Error_monad.tzresult
    (option Script_typed_ir.var_annot * option Script_typed_ir.type_annot *
      option Script_typed_ir.field_annot * option Script_typed_ir.field_annot).

Parameter parse_two_var_annot :
  Z -> list string ->
  Error_monad.tzresult
    (option Script_typed_ir.var_annot * option Script_typed_ir.var_annot).

Parameter parse_destr_annot :
  Z -> list string -> option Script_typed_ir.field_annot ->
  option Script_typed_ir.field_annot -> option Script_typed_ir.var_annot ->
  option Script_typed_ir.var_annot ->
  Error_monad.tzresult
    (option Script_typed_ir.var_annot * option Script_typed_ir.field_annot).

Parameter parse_entrypoint_annot :
  Z -> option (option Script_typed_ir.var_annot) -> list string ->
  Error_monad.tzresult
    (option Script_typed_ir.var_annot * option Script_typed_ir.field_annot).

Parameter parse_var_type_annot :
  Z -> list string ->
  Error_monad.tzresult
    (option Script_typed_ir.var_annot * option Script_typed_ir.type_annot).

Script_ir_translator

  • OCaml size: 5996 lines
  • Coq size: 7989 lines (+33% compared to OCaml)
script_ir_translator.ml 262 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Micheline
open Script
open Script_typed_ir
open Script_tc_errors
open Script_ir_annot
module Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking
module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse

type ex_comparable_ty =
  | Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty

type ex_ty = Ex_ty : 'a ty -> ex_ty

type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty

type tc_context =
  | Lambda : tc_context
  | Dip : 'a stack_ty * tc_context -> tc_context
  | Toplevel : {
      storage_type : 'sto ty;
      param_type : 'param ty;
      root_name : string option;
      legacy_create_contract_literal : bool;
    }
      -> tc_context

type unparsing_mode = Optimized | Readable

type type_logger =
  int ->
  (Script.expr * Script.annot) list ->
  (Script.expr * Script.annot) list ->
  unit

let add_dip ty annot prev =
  match prev with
  | Lambda | Toplevel _ ->
      Dip (Item_t (ty, Empty_t, annot), prev)
  | Dip (stack, _) ->
      Dip (Item_t (ty, stack, annot), prev)

(* ---- Type size accounting ------------------------------------------------*)

let rec comparable_type_size : type t a. (t, a) comparable_struct -> int =
 fun ty ->
  (* No wildcard to force the update when comparable_ty chages. *)
  match ty with
  | Int_key _ ->
      1
  | Nat_key _ ->
      1
  | String_key _ ->
      1
  | Bytes_key _ ->
      1
  | Mutez_key _ ->
      1
  | Bool_key _ ->
      1
  | Key_hash_key _ ->
      1
  | Timestamp_key _ ->
      1
  | Address_key _ ->
      1
  | Pair_key (_, (t, _), _) ->
      1 + comparable_type_size t

let rec type_size : type t. t ty -> int =
 fun ty ->
  match ty with
  | Unit_t _ ->
      1
  | Int_t _ ->
      1
  | Nat_t _ ->
      1
  | Signature_t _ ->
      1
  | Bytes_t _ ->
      1
  | String_t _ ->
      1
  | Mutez_t _ ->
      1
  | Key_hash_t _ ->
      1
  | Key_t _ ->
      1
  | Timestamp_t _ ->
      1
  | Address_t _ ->
      1
  | Bool_t _ ->
      1
  | Operation_t _ ->
      1
  | Pair_t ((l, _, _), (r, _, _), _, _) ->
      1 + type_size l + type_size r
  | Union_t ((l, _), (r, _), _, _) ->
      1 + type_size l + type_size r
  | Lambda_t (arg, ret, _) ->
      1 + type_size arg + type_size ret
  | Option_t (t, _, _) ->
      1 + type_size t
  | List_t (t, _, _) ->
      1 + type_size t
  | Set_t (k, _) ->
      1 + comparable_type_size k
  | Map_t (k, v, _, _) ->
      1 + comparable_type_size k + type_size v
  | Big_map_t (k, v, _) ->
      1 + comparable_type_size k + type_size v
  | Contract_t (arg, _) ->
      1 + type_size arg
  | Chain_id_t _ ->
      1

let rec type_size_of_stack_head : type st. st stack_ty -> up_to:int -> int =
 fun stack ~up_to ->
  match stack with
  | Empty_t ->
      0
  | Item_t (head, tail, _annot) ->
      if Compare.Int.(up_to > 0) then
        Compare.Int.max
          (type_size head)
          (type_size_of_stack_head tail ~up_to:(up_to - 1))
      else 0

(* This is the depth of the stack to inspect for sizes overflow. We
   only need to check the produced types that can be larger than the
   arguments. That's why Swap is 0 for instance as no type grows.
   Constant sized types are not checked: it is assumed they are lower
   than the bound (otherwise every program would be rejected). *)
let number_of_generated_growing_types : type b a. (b, a) instr -> int =
  function
  | Drop ->
      0
  | Dup ->
      0
  | Swap ->
      0
  | Const _ ->
      1
  | Cons_pair ->
      1
  | Car ->
      0
  | Cdr ->
      0
  | Cons_some ->
      1
  | Cons_none _ ->
      1
  | If_none _ ->
      0
  | Left ->
      0
  | Right ->
      0
  | If_left _ ->
      0
  | Cons_list ->
      1
  | Nil ->
      1
  | If_cons _ ->
      0
  | List_map _ ->
      1
  | List_size ->
      0
  | List_iter _ ->
      1
  | Empty_set _ ->
      1
  | Set_iter _ ->
      0
  | Set_mem ->
      0
  | Set_update ->
      0
  | Set_size ->
      0
  | Empty_map _ ->
      1
  | Map_map _ ->
      1
  | Map_iter _ ->
      1
  | Map_mem ->
      0
  | Map_get ->
      0
  | Map_update ->
      0
  | Map_size ->
      0
  | Empty_big_map _ ->
      1
  | Big_map_get ->
      0
  | Big_map_update ->
      0
  | Big_map_mem ->
      0
  | Concat_string ->
      0
  | Concat_string_pair ->
      0
  | Slice_string ->
      0
  | String_size ->
      0
  | Concat_bytes ->
      0
  | Concat_bytes_pair ->
      0
  | Slice_bytes ->
      0
  | Bytes_size ->
      0
  | Add_seconds_to_timestamp ->
      0
  | Add_timestamp_to_seconds ->
      0
  | Sub_timestamp_seconds ->
      0
  | Diff_timestamps ->
      0
  | Add_tez ->
      0
  | Sub_tez ->
      0
  | Mul_teznat ->
      0
  | Mul_nattez ->
      0
  | Ediv_teznat ->
      0
  | Ediv_tez ->
      0
  | Or ->
      0
  | And ->
      0
  | Xor ->
      0
  | Not ->
      0
  | Is_nat ->
      0
  | Neg_nat ->
      0
  | Neg_int ->
      0
  | Abs_int ->
      0
  | Int_nat ->
      0
  | Add_intint ->
      0
  | Add_intnat ->
      0
  | Add_natint ->
      0
  | Add_natnat ->
      0
  | Sub_int ->
      0
  | Mul_intint ->
      0
  | Mul_intnat ->
      0
  | Mul_natint ->
      0
  | Mul_natnat ->
      0
  | Ediv_intint ->
      0
  | Ediv_intnat ->
      0
  | Ediv_natint ->
      0
  | Ediv_natnat ->
      0
  | Lsl_nat ->
      0
  | Lsr_nat ->
      0
  | Or_nat ->
      0
  | And_nat ->
      0
  | And_int_nat ->
      0
  | Xor_nat ->
      0
  | Not_nat ->
      0
  | Not_int ->
      0
  | Seq _ ->
      0
  | If _ ->
      0
  | Loop _ ->
      0
  | Loop_left _ ->
      0
  | Dip _ ->
      0
  | Exec ->
      0
  | Apply _ ->
      0
  | Lambda _ ->
      1
  | Failwith _ ->
      1
  | Nop ->
      0
  | Compare _ ->
      1
  | Eq ->
      0
  | Neq ->
      0
  | Lt ->
      0
  | Gt ->
      0
  | Le ->
      0
  | Ge ->
      0
  | Address ->
      0
  | Contract _ ->
      1
  | Transfer_tokens ->
      1
  | Create_account ->
      0
  | Implicit_account ->
      0
  | Create_contract _ ->
      1
  | Create_contract_2 _ ->
      1
  | Now ->
      0
  | Balance ->
      0
  | Check_signature ->
      0
  | Hash_key ->
      0
  | Blake2b ->
      0
  | Sha256 ->
      0
  | Sha512 ->
      0
  | Steps_to_quota ->
      0
  | Source ->
      0
  | Sender ->
      0
  | Self _ ->
      1
  | Amount ->
      0
  | Set_delegate ->
      0
  | Pack _ ->
      0
  | Unpack _ ->
      1
  | Dig _ ->
      0
  | Dug _ ->
      0
  | Dipn _ ->
      0
  | Dropn _ ->
      0
  | ChainId ->
      0

(* ---- Error helpers -------------------------------------------------------*)

let location = function
  | Prim (loc, _, _, _)
  | Int (loc, _)
  | String (loc, _)
  | Bytes (loc, _)
  | Seq (loc, _) ->
      loc

let kind = function
  | Int _ ->
      Int_kind
  | String _ ->
      String_kind
  | Bytes _ ->
      Bytes_kind
  | Prim _ ->
      Prim_kind
  | Seq _ ->
      Seq_kind

let namespace = function
  | K_parameter | K_storage | K_code ->
      Keyword_namespace
  | D_False
  | D_Elt
  | D_Left
  | D_None
  | D_Pair
  | D_Right
  | D_Some
  | D_True
  | D_Unit ->
      Constant_namespace
  | I_PACK
  | I_UNPACK
  | I_BLAKE2B
  | I_SHA256
  | I_SHA512
  | I_ABS
  | I_ADD
  | I_AMOUNT
  | I_AND
  | I_BALANCE
  | I_CAR
  | I_CDR
  | I_CHAIN_ID
  | I_CHECK_SIGNATURE
  | I_COMPARE
  | I_CONCAT
  | I_CONS
  | I_CREATE_ACCOUNT
  | I_CREATE_CONTRACT
  | I_IMPLICIT_ACCOUNT
  | I_DIP
  | I_DROP
  | I_DUP
  | I_EDIV
  | I_EMPTY_BIG_MAP
  | I_EMPTY_MAP
  | I_EMPTY_SET
  | I_EQ
  | I_EXEC
  | I_APPLY
  | I_FAILWITH
  | I_GE
  | I_GET
  | I_GT
  | I_HASH_KEY
  | I_IF
  | I_IF_CONS
  | I_IF_LEFT
  | I_IF_NONE
  | I_INT
  | I_LAMBDA
  | I_LE
  | I_LEFT
  | I_LOOP
  | I_LSL
  | I_LSR
  | I_LT
  | I_MAP
  | I_MEM
  | I_MUL
  | I_NEG
  | I_NEQ
  | I_NIL
  | I_NONE
  | I_NOT
  | I_NOW
  | I_OR
  | I_PAIR
  | I_PUSH
  | I_RIGHT
  | I_SIZE
  | I_SOME
  | I_SOURCE
  | I_SENDER
  | I_SELF
  | I_SLICE
  | I_STEPS_TO_QUOTA
  | I_SUB
  | I_SWAP
  | I_TRANSFER_TOKENS
  | I_SET_DELEGATE
  | I_UNIT
  | I_UPDATE
  | I_XOR
  | I_ITER
  | I_LOOP_LEFT
  | I_ADDRESS
  | I_CONTRACT
  | I_ISNAT
  | I_CAST
  | I_RENAME
  | I_DIG
  | I_DUG ->
      Instr_namespace
  | T_bool
  | T_contract
  | T_int
  | T_key
  | T_key_hash
  | T_lambda
  | T_list
  | T_map
  | T_big_map
  | T_nat
  | T_option
  | T_or
  | T_pair
  | T_set
  | T_signature
  | T_string
  | T_bytes
  | T_mutez
  | T_timestamp
  | T_unit
  | T_operation
  | T_address
  | T_chain_id ->
      Type_namespace

let unexpected expr exp_kinds exp_ns exp_prims =
  match expr with
  | Int (loc, _) ->
      Invalid_kind (loc, Prim_kind :: exp_kinds, Int_kind)
  | String (loc, _) ->
      Invalid_kind (loc, Prim_kind :: exp_kinds, String_kind)
  | Bytes (loc, _) ->
      Invalid_kind (loc, Prim_kind :: exp_kinds, Bytes_kind)
  | Seq (loc, _) ->
      Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind)
  | Prim (loc, name, _, _) -> (
    match (namespace name, exp_ns) with
    | (Type_namespace, Type_namespace)
    | (Instr_namespace, Instr_namespace)
    | (Constant_namespace, Constant_namespace) ->
        Invalid_primitive (loc, exp_prims, name)
    | (ns, _) ->
        Invalid_namespace (loc, name, exp_ns, ns) )

let check_kind kinds expr =
  let kind = kind expr in
  if List.mem kind kinds then return_unit
  else
    let loc = location expr in
    fail (Invalid_kind (loc, kinds, kind))

(* ---- Sets and Maps -------------------------------------------------------*)

let wrap_compare compare a b =
  let res = compare a b in
  if Compare.Int.(res = 0) then 0 else if Compare.Int.(res > 0) then 1 else -1

let rec compare_comparable :
    type a s. (a, s) comparable_struct -> a -> a -> int =
 fun kind ->
  match kind with
  | String_key _ ->
      wrap_compare Compare.String.compare
  | Bool_key _ ->
      wrap_compare Compare.Bool.compare
  | Mutez_key _ ->
      wrap_compare Tez.compare
  | Key_hash_key _ ->
      wrap_compare Signature.Public_key_hash.compare
  | Int_key _ ->
      wrap_compare Script_int.compare
  | Nat_key _ ->
      wrap_compare Script_int.compare
  | Timestamp_key _ ->
      wrap_compare Script_timestamp.compare
  | Address_key _ ->
      wrap_compare
      @@ fun (x, ex) (y, ey) ->
      let lres = Contract.compare x y in
      if Compare.Int.(lres = 0) then Compare.String.compare ex ey else lres
  | Bytes_key _ ->
      wrap_compare MBytes.compare
  | Pair_key ((tl, _), (tr, _), _) ->
      fun (lx, rx) (ly, ry) ->
        let lres = compare_comparable tl lx ly in
        if Compare.Int.(lres = 0) then compare_comparable tr rx ry else lres

let empty_set : type a. a comparable_ty -> a set =
 fun ty ->
  let module OPS = Set.Make (struct
    type t = a

    let compare = compare_comparable ty
  end) in
  ( module struct
    type elt = a

    let elt_ty = ty

    module OPS = OPS

    let boxed = OPS.empty

    let size = 0
  end )

let set_update : type a. a -> bool -> a set -> a set =
 fun v b (module Box) ->
  ( module struct
    type elt = a

    let elt_ty = Box.elt_ty

    module OPS = Box.OPS

    let boxed =
      if b then Box.OPS.add v Box.boxed else Box.OPS.remove v Box.boxed

    let size =
      let mem = Box.OPS.mem v Box.boxed in
      if mem then if b then Box.size else Box.size - 1
      else if b then Box.size + 1
      else Box.size
  end )

let set_mem : type elt. elt -> elt set -> bool =
 fun v (module Box) -> Box.OPS.mem v Box.boxed

let set_fold : type elt acc. (elt -> acc -> acc) -> elt set -> acc -> acc =
 fun f (module Box) -> Box.OPS.fold f Box.boxed

let set_size : type elt. elt set -> Script_int.n Script_int.num =
 fun (module Box) -> Script_int.(abs (of_int Box.size))

let map_key_ty : type a b. (a, b) map -> a comparable_ty =
 fun (module Box) -> Box.key_ty

let empty_map : type a b. a comparable_ty -> (a, b) map =
 fun ty ->
  let module OPS = Map.Make (struct
    type t = a

    let compare = compare_comparable ty
  end) in
  ( module struct
    type key = a

    type value = b

    let key_ty = ty

    module OPS = OPS

    let boxed = (OPS.empty, 0)
  end )

let map_get : type key value. key -> (key, value) map -> value option =
 fun k (module Box) -> Box.OPS.find_opt k (fst Box.boxed)

let map_update : type a b. a -> b option -> (a, b) map -> (a, b) map =
 fun k v (module Box) ->
  ( module struct
    type key = a

    type value = b

    let key_ty = Box.key_ty

    module OPS = Box.OPS

    let boxed =
      let (map, size) = Box.boxed in
      let contains = Box.OPS.mem k map in
      match v with
      | Some v ->
          (Box.OPS.add k v map, size + if contains then 0 else 1)
      | None ->
          (Box.OPS.remove k map, size - if contains then 1 else 0)
  end )

let map_set : type a b. a -> b -> (a, b) map -> (a, b) map =
 fun k v (module Box) ->
  ( module struct
    type key = a

    type value = b

    let key_ty = Box.key_ty

    module OPS = Box.OPS

    let boxed =
      let (map, size) = Box.boxed in
      (Box.OPS.add k v map, if Box.OPS.mem k map then size else size + 1)
  end )

let map_mem : type key value. key -> (key, value) map -> bool =
 fun k (module Box) -> Box.OPS.mem k (fst Box.boxed)

let map_fold :
    type key value acc.
    (key -> value -> acc -> acc) -> (key, value) map -> acc -> acc =
 fun f (module Box) -> Box.OPS.fold f (fst Box.boxed)

let map_size : type key value. (key, value) map -> Script_int.n Script_int.num
    =
 fun (module Box) -> Script_int.(abs (of_int (snd Box.boxed)))

(* ---- Unparsing (Typed IR -> Untyped expressions) of types -----------------*)

let rec ty_of_comparable_ty : type a s. (a, s) comparable_struct -> a ty =
  function
  | Int_key tname ->
      Int_t tname
  | Nat_key tname ->
      Nat_t tname
  | String_key tname ->
      String_t tname
  | Bytes_key tname ->
      Bytes_t tname
  | Mutez_key tname ->
      Mutez_t tname
  | Bool_key tname ->
      Bool_t tname
  | Key_hash_key tname ->
      Key_hash_t tname
  | Timestamp_key tname ->
      Timestamp_t tname
  | Address_key tname ->
      Address_t tname
  | Pair_key ((l, al), (r, ar), tname) ->
      Pair_t
        ( (ty_of_comparable_ty l, al, None),
          (ty_of_comparable_ty r, ar, None),
          tname,
          false )

let rec comparable_ty_of_ty : type a. a ty -> a comparable_ty option = function
  | Int_t tname ->
      Some (Int_key tname)
  | Nat_t tname ->
      Some (Nat_key tname)
  | String_t tname ->
      Some (String_key tname)
  | Bytes_t tname ->
      Some (Bytes_key tname)
  | Mutez_t tname ->
      Some (Mutez_key tname)
  | Bool_t tname ->
      Some (Bool_key tname)
  | Key_hash_t tname ->
      Some (Key_hash_key tname)
  | Timestamp_t tname ->
      Some (Timestamp_key tname)
  | Address_t tname ->
      Some (Address_key tname)
  | Pair_t ((l, al, _), (r, ar, _), pname, _) -> (
    match comparable_ty_of_ty r with
    | None ->
        None
    | Some rty -> (
      match comparable_ty_of_ty l with
      | None ->
          None
      | Some (Pair_key _) ->
          None (* not a comb *)
      | Some (Int_key tname) ->
          Some (Pair_key ((Int_key tname, al), (rty, ar), pname))
      | Some (Nat_key tname) ->
          Some (Pair_key ((Nat_key tname, al), (rty, ar), pname))
      | Some (String_key tname) ->
          Some (Pair_key ((String_key tname, al), (rty, ar), pname))
      | Some (Bytes_key tname) ->
          Some (Pair_key ((Bytes_key tname, al), (rty, ar), pname))
      | Some (Mutez_key tname) ->
          Some (Pair_key ((Mutez_key tname, al), (rty, ar), pname))
      | Some (Bool_key tname) ->
          Some (Pair_key ((Bool_key tname, al), (rty, ar), pname))
      | Some (Key_hash_key tname) ->
          Some (Pair_key ((Key_hash_key tname, al), (rty, ar), pname))
      | Some (Timestamp_key tname) ->
          Some (Pair_key ((Timestamp_key tname, al), (rty, ar), pname))
      | Some (Address_key tname) ->
          Some (Pair_key ((Address_key tname, al), (rty, ar), pname)) ) )
  | _ ->
      None

let add_field_annot a var = function
  | Prim (loc, prim, args, annots) ->
      Prim
        ( loc,
          prim,
          args,
          annots @ unparse_field_annot a @ unparse_var_annot var )
  | expr ->
      expr

let rec unparse_comparable_ty :
    type a s. (a, s) comparable_struct -> Script.node = function
  | Int_key tname ->
      Prim (-1, T_int, [], unparse_type_annot tname)
  | Nat_key tname ->
      Prim (-1, T_nat, [], unparse_type_annot tname)
  | String_key tname ->
      Prim (-1, T_string, [], unparse_type_annot tname)
  | Bytes_key tname ->
      Prim (-1, T_bytes, [], unparse_type_annot tname)
  | Mutez_key tname ->
      Prim (-1, T_mutez, [], unparse_type_annot tname)
  | Bool_key tname ->
      Prim (-1, T_bool, [], unparse_type_annot tname)
  | Key_hash_key tname ->
      Prim (-1, T_key_hash, [], unparse_type_annot tname)
  | Timestamp_key tname ->
      Prim (-1, T_timestamp, [], unparse_type_annot tname)
  | Address_key tname ->
      Prim (-1, T_address, [], unparse_type_annot tname)
  | Pair_key ((l, al), (r, ar), pname) ->
      let tl = add_field_annot al None (unparse_comparable_ty l) in
      let tr = add_field_annot ar None (unparse_comparable_ty r) in
      Prim (-1, T_pair, [tl; tr], unparse_type_annot pname)

let rec unparse_ty_no_lwt :
    type a. context -> a ty -> (Script.node * context) tzresult =
 fun ctxt ty ->
  Gas.consume ctxt Unparse_costs.cycle
  >>? fun ctxt ->
  let return ctxt (name, args, annot) =
    let result = Prim (-1, name, args, annot) in
    Gas.consume ctxt (Unparse_costs.prim_cost (List.length args) annot)
    >>? fun ctxt -> ok (result, ctxt)
  in
  match ty with
  | Unit_t tname ->
      return ctxt (T_unit, [], unparse_type_annot tname)
  | Int_t tname ->
      return ctxt (T_int, [], unparse_type_annot tname)
  | Nat_t tname ->
      return ctxt (T_nat, [], unparse_type_annot tname)
  | String_t tname ->
      return ctxt (T_string, [], unparse_type_annot tname)
  | Bytes_t tname ->
      return ctxt (T_bytes, [], unparse_type_annot tname)
  | Mutez_t tname ->
      return ctxt (T_mutez, [], unparse_type_annot tname)
  | Bool_t tname ->
      return ctxt (T_bool, [], unparse_type_annot tname)
  | Key_hash_t tname ->
      return ctxt (T_key_hash, [], unparse_type_annot tname)
  | Key_t tname ->
      return ctxt (T_key, [], unparse_type_annot tname)
  | Timestamp_t tname ->
      return ctxt (T_timestamp, [], unparse_type_annot tname)
  | Address_t tname ->
      return ctxt (T_address, [], unparse_type_annot tname)
  | Signature_t tname ->
      return ctxt (T_signature, [], unparse_type_annot tname)
  | Operation_t tname ->
      return ctxt (T_operation, [], unparse_type_annot tname)
  | Chain_id_t tname ->
      return ctxt (T_chain_id, [], unparse_type_annot tname)
  | Contract_t (ut, tname) ->
      unparse_ty_no_lwt ctxt ut
      >>? fun (t, ctxt) ->
      return ctxt (T_contract, [t], unparse_type_annot tname)
  | Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), tname, _) ->
      let annot = unparse_type_annot tname in
      unparse_ty_no_lwt ctxt utl
      >>? fun (utl, ctxt) ->
      let tl = add_field_annot l_field l_var utl in
      unparse_ty_no_lwt ctxt utr
      >>? fun (utr, ctxt) ->
      let tr = add_field_annot r_field r_var utr in
      return ctxt (T_pair, [tl; tr], annot)
  | Union_t ((utl, l_field), (utr, r_field), tname, _) ->
      let annot = unparse_type_annot tname in
      unparse_ty_no_lwt ctxt utl
      >>? fun (utl, ctxt) ->
      let tl = add_field_annot l_field None utl in
      unparse_ty_no_lwt ctxt utr
      >>? fun (utr, ctxt) ->
      let tr = add_field_annot r_field None utr in
      return ctxt (T_or, [tl; tr], annot)
  | Lambda_t (uta, utr, tname) ->
      unparse_ty_no_lwt ctxt uta
      >>? fun (ta, ctxt) ->
      unparse_ty_no_lwt ctxt utr
      >>? fun (tr, ctxt) ->
      return ctxt (T_lambda, [ta; tr], unparse_type_annot tname)
  | Option_t (ut, tname, _) ->
      let annot = unparse_type_annot tname in
      unparse_ty_no_lwt ctxt ut
      >>? fun (ut, ctxt) -> return ctxt (T_option, [ut], annot)
  | List_t (ut, tname, _) ->
      unparse_ty_no_lwt ctxt ut
      >>? fun (t, ctxt) -> return ctxt (T_list, [t], unparse_type_annot tname)
  | Set_t (ut, tname) ->
      let t = unparse_comparable_ty ut in
      return ctxt (T_set, [t], unparse_type_annot tname)
  | Map_t (uta, utr, tname, _) ->
      let ta = unparse_comparable_ty uta in
      unparse_ty_no_lwt ctxt utr
      >>? fun (tr, ctxt) ->
      return ctxt (T_map, [ta; tr], unparse_type_annot tname)
  | Big_map_t (uta, utr, tname) ->
      let ta = unparse_comparable_ty uta in
      unparse_ty_no_lwt ctxt utr
      >>? fun (tr, ctxt) ->
      return ctxt (T_big_map, [ta; tr], unparse_type_annot tname)

let unparse_ty ctxt ty = Lwt.return (unparse_ty_no_lwt ctxt ty)

let rec strip_var_annots = function
  | (Int _ | String _ | Bytes _) as atom ->
      atom
  | Seq (loc, args) ->
      Seq (loc, List.map strip_var_annots args)
  | Prim (loc, name, args, annots) ->
      let not_var_annot s = Compare.Char.(s.[0] <> '@') in
      let annots = List.filter not_var_annot annots in
      Prim (loc, name, List.map strip_var_annots args, annots)

let serialize_ty_for_error ctxt ty =
  unparse_ty_no_lwt ctxt ty
  |> record_trace Cannot_serialize_error
  >|? fun (ty, ctxt) -> (strip_locations (strip_var_annots ty), ctxt)

let rec unparse_stack :
    type a.
    context ->
    a stack_ty ->
    ((Script.expr * Script.annot) list * context) tzresult Lwt.t =
 fun ctxt -> function
  | Empty_t ->
      return ([], ctxt)
  | Item_t (ty, rest, annot) ->
      unparse_ty ctxt ty
      >>=? fun (uty, ctxt) ->
      unparse_stack ctxt rest
      >>=? fun (urest, ctxt) ->
      return ((strip_locations uty, unparse_var_annot annot) :: urest, ctxt)

let serialize_stack_for_error ctxt stack_ty =
  trace Cannot_serialize_error (unparse_stack ctxt stack_ty)

let name_of_ty : type a. a ty -> type_annot option = function
  | Unit_t tname ->
      tname
  | Int_t tname ->
      tname
  | Nat_t tname ->
      tname
  | String_t tname ->
      tname
  | Bytes_t tname ->
      tname
  | Mutez_t tname ->
      tname
  | Bool_t tname ->
      tname
  | Key_hash_t tname ->
      tname
  | Key_t tname ->
      tname
  | Timestamp_t tname ->
      tname
  | Address_t tname ->
      tname
  | Signature_t tname ->
      tname
  | Operation_t tname ->
      tname
  | Chain_id_t tname ->
      tname
  | Contract_t (_, tname) ->
      tname
  | Pair_t (_, _, tname, _) ->
      tname
  | Union_t (_, _, tname, _) ->
      tname
  | Lambda_t (_, _, tname) ->
      tname
  | Option_t (_, tname, _) ->
      tname
  | List_t (_, tname, _) ->
      tname
  | Set_t (_, tname) ->
      tname
  | Map_t (_, _, tname, _) ->
      tname
  | Big_map_t (_, _, tname) ->
      tname

(* ---- Equality witnesses --------------------------------------------------*)

type ('ta, 'tb) eq = Eq : ('same, 'same) eq

let comparable_ty_eq :
    type ta tb.
    context ->
    ta comparable_ty ->
    tb comparable_ty ->
    (ta comparable_ty, tb comparable_ty) eq tzresult =
 fun ctxt ta tb ->
  match (ta, tb) with
  | (Int_key _, Int_key _) ->
      Ok Eq
  | (Nat_key _, Nat_key _) ->
      Ok Eq
  | (String_key _, String_key _) ->
      Ok Eq
  | (Bytes_key _, Bytes_key _) ->
      Ok Eq
  | (Mutez_key _, Mutez_key _) ->
      Ok Eq
  | (Bool_key _, Bool_key _) ->
      Ok Eq
  | (Key_hash_key _, Key_hash_key _) ->
      Ok Eq
  | (Timestamp_key _, Timestamp_key _) ->
      Ok Eq
  | (Address_key _, Address_key _) ->
      Ok Eq
  | (_, _) ->
      serialize_ty_for_error ctxt (ty_of_comparable_ty ta)
      >>? fun (ta, ctxt) ->
      serialize_ty_for_error ctxt (ty_of_comparable_ty tb)
      >>? fun (tb, _ctxt) -> error (Inconsistent_types (ta, tb))

let record_inconsistent ctxt ta tb =
  record_trace_eval (fun () ->
      serialize_ty_for_error ctxt ta
      >>? fun (ta, ctxt) ->
      serialize_ty_for_error ctxt tb
      >|? fun (tb, _ctxt) -> Inconsistent_types (ta, tb))

let record_inconsistent_type_annotations ctxt loc ta tb =
  record_trace_eval (fun () ->
      serialize_ty_for_error ctxt ta
      >>? fun (ta, ctxt) ->
      serialize_ty_for_error ctxt tb
      >|? fun (tb, _ctxt) -> Inconsistent_type_annotations (loc, ta, tb))

let rec ty_eq :
    type ta tb.
    context -> ta ty -> tb ty -> ((ta ty, tb ty) eq * context) tzresult =
 fun ctxt ta tb ->
  let ok (eq : (ta ty, tb ty) eq) ctxt nb_args :
      ((ta ty, tb ty) eq * context) tzresult =
    Gas.consume ctxt (Typecheck_costs.type_ (2 * nb_args))
    >>? fun ctxt -> Ok (eq, ctxt)
  in
  Gas.consume ctxt Typecheck_costs.cycle
  >>? fun ctxt ->
  match (ta, tb) with
  | (Unit_t _, Unit_t _) ->
      ok Eq ctxt 0
  | (Int_t _, Int_t _) ->
      ok Eq ctxt 0
  | (Nat_t _, Nat_t _) ->
      ok Eq ctxt 0
  | (Key_t _, Key_t _) ->
      ok Eq ctxt 0
  | (Key_hash_t _, Key_hash_t _) ->
      ok Eq ctxt 0
  | (String_t _, String_t _) ->
      ok Eq ctxt 0
  | (Bytes_t _, Bytes_t _) ->
      ok Eq ctxt 0
  | (Signature_t _, Signature_t _) ->
      ok Eq ctxt 0
  | (Mutez_t _, Mutez_t _) ->
      ok Eq ctxt 0
  | (Timestamp_t _, Timestamp_t _) ->
      ok Eq ctxt 0
  | (Chain_id_t _, Chain_id_t _) ->
      ok Eq ctxt 0
  | (Address_t _, Address_t _) ->
      ok Eq ctxt 0
  | (Bool_t _, Bool_t _) ->
      ok Eq ctxt 0
  | (Operation_t _, Operation_t _) ->
      ok Eq ctxt 0
  | (Map_t (tal, tar, _, _), Map_t (tbl, tbr, _, _)) ->
      comparable_ty_eq ctxt tal tbl
      >>? (fun Eq -> ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
      |> record_inconsistent ctxt ta tb
  | (Big_map_t (tal, tar, _), Big_map_t (tbl, tbr, _)) ->
      comparable_ty_eq ctxt tal tbl
      >>? (fun Eq -> ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
      |> record_inconsistent ctxt ta tb
  | (Set_t (ea, _), Set_t (eb, _)) ->
      comparable_ty_eq ctxt ea eb
      >>? (fun Eq -> ok Eq ctxt 1)
      |> record_inconsistent ctxt ta tb
  | ( Pair_t ((tal, _, _), (tar, _, _), _, _),
      Pair_t ((tbl, _, _), (tbr, _, _), _, _) ) ->
      ty_eq ctxt tal tbl
      >>? (fun (Eq, ctxt) ->
            ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
      |> record_inconsistent ctxt ta tb
  | (Union_t ((tal, _), (tar, _), _, _), Union_t ((tbl, _), (tbr, _), _, _)) ->
      ty_eq ctxt tal tbl
      >>? (fun (Eq, ctxt) ->
            ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
      |> record_inconsistent ctxt ta tb
  | (Lambda_t (tal, tar, _), Lambda_t (tbl, tbr, _)) ->
      ty_eq ctxt tal tbl
      >>? (fun (Eq, ctxt) ->
            ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
      |> record_inconsistent ctxt ta tb
  | (Contract_t (tal, _), Contract_t (tbl, _)) ->
      ty_eq ctxt tal tbl
      >>? (fun (Eq, ctxt) -> ok Eq ctxt 1)
      |> record_inconsistent ctxt ta tb
  | (Option_t (tva, _, _), Option_t (tvb, _, _)) ->
      ty_eq ctxt tva tvb
      >>? (fun (Eq, ctxt) -> ok Eq ctxt 1)
      |> record_inconsistent ctxt ta tb
  | (List_t (tva, _, _), List_t (tvb, _, _)) ->
      ty_eq ctxt tva tvb
      >>? (fun (Eq, ctxt) -> ok Eq ctxt 1)
      |> record_inconsistent ctxt ta tb
  | (_, _) ->
      serialize_ty_for_error ctxt ta
      >>? fun (ta, ctxt) ->
      serialize_ty_for_error ctxt tb
      >>? fun (tb, _ctxt) -> error (Inconsistent_types (ta, tb))

let rec stack_ty_eq :
    type ta tb.
    context ->
    int ->
    ta stack_ty ->
    tb stack_ty ->
    ((ta stack_ty, tb stack_ty) eq * context) tzresult =
 fun ctxt lvl ta tb ->
  match (ta, tb) with
  | (Item_t (tva, ra, _), Item_t (tvb, rb, _)) ->
      ty_eq ctxt tva tvb
      |> record_trace (Bad_stack_item lvl)
      >>? fun (Eq, ctxt) ->
      stack_ty_eq ctxt (lvl + 1) ra rb
      >>? fun (Eq, ctxt) ->
      (Ok (Eq, ctxt) : ((ta stack_ty, tb stack_ty) eq * context) tzresult)
  | (Empty_t, Empty_t) ->
      Ok (Eq, ctxt)
  | (_, _) ->
      error Bad_stack_length

let merge_comparable_types :
    type ta.
    legacy:bool ->
    ta comparable_ty ->
    ta comparable_ty ->
    ta comparable_ty tzresult =
 fun ~legacy ta tb ->
  match (ta, tb) with
  | (Int_key annot_a, Int_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Int_key annot
  | (Nat_key annot_a, Nat_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Nat_key annot
  | (String_key annot_a, String_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b
      >|? fun annot -> String_key annot
  | (Bytes_key annot_a, Bytes_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Bytes_key annot
  | (Mutez_key annot_a, Mutez_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Mutez_key annot
  | (Bool_key annot_a, Bool_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Bool_key annot
  | (Key_hash_key annot_a, Key_hash_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b
      >|? fun annot -> Key_hash_key annot
  | (Timestamp_key annot_a, Timestamp_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b
      >|? fun annot -> Timestamp_key annot
  | (Address_key annot_a, Address_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b
      >|? fun annot -> Address_key annot
  | (_, _) ->
      assert false

(* FIXME: fix injectivity of some types *)

let merge_types :
    type b.
    legacy:bool ->
    context ->
    Script.location ->
    b ty ->
    b ty ->
    (b ty * context) tzresult =
 fun ~legacy ->
  let rec help : type a. context -> a ty -> a ty -> (a ty * context) tzresult =
   fun ctxt ty1 ty2 ->
    match (ty1, ty2) with
    | (Unit_t tn1, Unit_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Unit_t tname, ctxt)
    | (Int_t tn1, Int_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Int_t tname, ctxt)
    | (Nat_t tn1, Nat_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Nat_t tname, ctxt)
    | (Key_t tn1, Key_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Key_t tname, ctxt)
    | (Key_hash_t tn1, Key_hash_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Key_hash_t tname, ctxt)
    | (String_t tn1, String_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (String_t tname, ctxt)
    | (Bytes_t tn1, Bytes_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Bytes_t tname, ctxt)
    | (Signature_t tn1, Signature_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Signature_t tname, ctxt)
    | (Mutez_t tn1, Mutez_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Mutez_t tname, ctxt)
    | (Timestamp_t tn1, Timestamp_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Timestamp_t tname, ctxt)
    | (Address_t tn1, Address_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Address_t tname, ctxt)
    | (Bool_t tn1, Bool_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Bool_t tname, ctxt)
    | (Chain_id_t tn1, Chain_id_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Chain_id_t tname, ctxt)
    | (Operation_t tn1, Operation_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Operation_t tname, ctxt)
    | (Map_t (tal, tar, tn1, has_big_map), Map_t (tbl, tbr, tn2, _)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tar tbr
        >>? fun (value, ctxt) ->
        ty_eq ctxt tar value
        >>? fun (Eq, ctxt) ->
        merge_comparable_types ~legacy tal tbl
        >|? fun tk -> (Map_t (tk, value, tname, has_big_map), ctxt)
    | (Big_map_t (tal, tar, tn1), Big_map_t (tbl, tbr, tn2)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tar tbr
        >>? fun (value, ctxt) ->
        ty_eq ctxt tar value
        >>? fun (Eq, ctxt) ->
        merge_comparable_types ~legacy tal tbl
        >|? fun tk -> (Big_map_t (tk, value, tname), ctxt)
    | (Set_t (ea, tn1), Set_t (eb, tn2)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        merge_comparable_types ~legacy ea eb
        >|? fun e -> (Set_t (e, tname), ctxt)
    | ( Pair_t
          ((tal, l_field1, l_var1), (tar, r_field1, r_var1), tn1, has_big_map),
        Pair_t ((tbl, l_field2, l_var2), (tbr, r_field2, r_var2), tn2, _) ) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        merge_field_annot ~legacy l_field1 l_field2
        >>? fun l_field ->
        merge_field_annot ~legacy r_field1 r_field2
        >>? fun r_field ->
        let l_var = merge_var_annot l_var1 l_var2 in
        let r_var = merge_var_annot r_var1 r_var2 in
        help ctxt tal tbl
        >>? fun (left_ty, ctxt) ->
        help ctxt tar tbr
        >|? fun (right_ty, ctxt) ->
        ( Pair_t
            ( (left_ty, l_field, l_var),
              (right_ty, r_field, r_var),
              tname,
              has_big_map ),
          ctxt )
    | ( Union_t ((tal, tal_annot), (tar, tar_annot), tn1, has_big_map),
        Union_t ((tbl, tbl_annot), (tbr, tbr_annot), tn2, _) ) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        merge_field_annot ~legacy tal_annot tbl_annot
        >>? fun left_annot ->
        merge_field_annot ~legacy tar_annot tbr_annot
        >>? fun right_annot ->
        help ctxt tal tbl
        >>? fun (left_ty, ctxt) ->
        help ctxt tar tbr
        >|? fun (right_ty, ctxt) ->
        ( Union_t
            ((left_ty, left_annot), (right_ty, right_annot), tname, has_big_map),
          ctxt )
    | (Lambda_t (tal, tar, tn1), Lambda_t (tbl, tbr, tn2)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tal tbl
        >>? fun (left_ty, ctxt) ->
        help ctxt tar tbr
        >|? fun (right_ty, ctxt) -> (Lambda_t (left_ty, right_ty, tname), ctxt)
    | (Contract_t (tal, tn1), Contract_t (tbl, tn2)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tal tbl
        >|? fun (arg_ty, ctxt) -> (Contract_t (arg_ty, tname), ctxt)
    | (Option_t (tva, tn1, has_big_map), Option_t (tvb, tn2, _)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tva tvb
        >|? fun (ty, ctxt) -> (Option_t (ty, tname, has_big_map), ctxt)
    | (List_t (tva, tn1, has_big_map), List_t (tvb, tn2, _)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tva tvb
        >|? fun (ty, ctxt) -> (List_t (ty, tname, has_big_map), ctxt)
    | (_, _) ->
        assert false
  in
  fun ctxt loc ty1 ty2 ->
    record_inconsistent_type_annotations ctxt loc ty1 ty2 (help ctxt ty1 ty2)

let merge_stacks :
    type ta.
    legacy:bool ->
    Script.location ->
    context ->
    ta stack_ty ->
    ta stack_ty ->
    (ta stack_ty * context) tzresult =
 fun ~legacy loc ->
  let rec help :
      type a.
      context -> a stack_ty -> a stack_ty -> (a stack_ty * context) tzresult =
   fun ctxt stack1 stack2 ->
    match (stack1, stack2) with
    | (Empty_t, Empty_t) ->
        ok (Empty_t, ctxt)
    | (Item_t (ty1, rest1, annot1), Item_t (ty2, rest2, annot2)) ->
        let annot = merge_var_annot annot1 annot2 in
        merge_types ~legacy ctxt loc ty1 ty2
        >>? fun (ty, ctxt) ->
        help ctxt rest1 rest2
        >|? fun (rest, ctxt) -> (Item_t (ty, rest, annot), ctxt)
  in
  help

let has_big_map : type t. t ty -> bool = function
  | Unit_t _ ->
      false
  | Int_t _ ->
      false
  | Nat_t _ ->
      false
  | Signature_t _ ->
      false
  | String_t _ ->
      false
  | Bytes_t _ ->
      false
  | Mutez_t _ ->
      false
  | Key_hash_t _ ->
      false
  | Key_t _ ->
      false
  | Timestamp_t _ ->
      false
  | Address_t _ ->
      false
  | Bool_t _ ->
      false
  | Lambda_t (_, _, _) ->
      false
  | Set_t (_, _) ->
      false
  | Big_map_t (_, _, _) ->
      true
  | Contract_t (_, _) ->
      false
  | Operation_t _ ->
      false
  | Chain_id_t _ ->
      false
  | Pair_t (_, _, _, has_big_map) ->
      has_big_map
  | Union_t (_, _, _, has_big_map) ->
      has_big_map
  | Option_t (_, _, has_big_map) ->
      has_big_map
  | List_t (_, _, has_big_map) ->
      has_big_map
  | Map_t (_, _, _, has_big_map) ->
      has_big_map

(* ---- Type checker results -------------------------------------------------*)

type 'bef judgement =
  | Typed : ('bef, 'aft) descr -> 'bef judgement
  | Failed : {
      descr : 'aft. 'aft stack_ty -> ('bef, 'aft) descr;
    }
      -> 'bef judgement

(* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*)

type ('t, 'f, 'b) branch = {
  branch : 'r. ('t, 'r) descr -> ('f, 'r) descr -> ('b, 'r) descr;
}
[@@unboxed]

let merge_branches :
    type bef a b.
    legacy:bool ->
    context ->
    int ->
    a judgement ->
    b judgement ->
    (a, b, bef) branch ->
    (bef judgement * context) tzresult Lwt.t =
 fun ~legacy ctxt loc btr bfr {branch} ->
  match (btr, bfr) with
  | (Typed ({aft = aftbt; _} as dbt), Typed ({aft = aftbf; _} as dbf)) ->
      let unmatched_branches () =
        serialize_stack_for_error ctxt aftbt
        >>=? fun (aftbt, ctxt) ->
        serialize_stack_for_error ctxt aftbf
        >>|? fun (aftbf, _ctxt) -> Unmatched_branches (loc, aftbt, aftbf)
      in
      trace_eval
        unmatched_branches
        ( Lwt.return (stack_ty_eq ctxt 1 aftbt aftbf)
        >>=? fun (Eq, ctxt) ->
        Lwt.return (merge_stacks ~legacy loc ctxt aftbt aftbf)
        >>=? fun (merged_stack, ctxt) ->
        return
          ( Typed
              (branch
                 {dbt with aft = merged_stack}
                 {dbf with aft = merged_stack}),
            ctxt ) )
  | (Failed {descr = descrt}, Failed {descr = descrf}) ->
      let descr ret = branch (descrt ret) (descrf ret) in
      return (Failed {descr}, ctxt)
  | (Typed dbt, Failed {descr = descrf}) ->
      return (Typed (branch dbt (descrf dbt.aft)), ctxt)
  | (Failed {descr = descrt}, Typed dbf) ->
      return (Typed (branch (descrt dbf.aft) dbf), ctxt)

let rec parse_comparable_ty :
    context -> Script.node -> (ex_comparable_ty * context) tzresult =
 fun ctxt ty ->
  Gas.consume ctxt Typecheck_costs.cycle
  >>? fun ctxt ->
  Gas.consume ctxt (Typecheck_costs.type_ 0)
  >>? fun ctxt ->
  match ty with
  | Prim (loc, T_int, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Int_key tname), ctxt)
  | Prim (loc, T_nat, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Nat_key tname), ctxt)
  | Prim (loc, T_string, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (String_key tname), ctxt)
  | Prim (loc, T_bytes, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Bytes_key tname), ctxt)
  | Prim (loc, T_mutez, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Mutez_key tname), ctxt)
  | Prim (loc, T_bool, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Bool_key tname), ctxt)
  | Prim (loc, T_key_hash, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Key_hash_key tname), ctxt)
  | Prim (loc, T_timestamp, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Timestamp_key tname), ctxt)
  | Prim (loc, T_address, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Address_key tname), ctxt)
  | Prim
      ( loc,
        ( ( T_int
          | T_nat
          | T_string
          | T_mutez
          | T_bool
          | T_key
          | T_address
          | T_timestamp ) as prim ),
        l,
        _ ) ->
      error (Invalid_arity (loc, prim, 0, List.length l))
  | Prim
      ( loc,
        ( T_pair
        | T_or
        | T_set
        | T_map
        | T_list
        | T_option
        | T_lambda
        | T_unit
        | T_signature
        | T_contract ),
        _,
        _ ) ->
      error (Comparable_type_expected (loc, Micheline.strip_locations ty))
  | expr ->
      error
      @@ unexpected
           expr
           []
           Type_namespace
           [ T_int;
             T_nat;
             T_string;
             T_mutez;
             T_bool;
             T_key;
             T_key_hash;
             T_timestamp ]

and parse_packable_ty :
    context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
 fun ctxt ~legacy ->
  parse_ty
    ctxt
    ~legacy
    ~allow_big_map:false
    ~allow_operation:false
    ~allow_contract:legacy

and parse_parameter_ty :
    context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
 fun ctxt ~legacy ->
  parse_ty
    ctxt
    ~legacy
    ~allow_big_map:true
    ~allow_operation:false
    ~allow_contract:true

and parse_any_ty :
    context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
 fun ctxt ~legacy ->
  parse_ty
    ctxt
    ~legacy
    ~allow_big_map:true
    ~allow_operation:true
    ~allow_contract:true

and parse_ty :
    context ->
    legacy:bool ->
    allow_big_map:bool ->
    allow_operation:bool ->
    allow_contract:bool ->
    Script.node ->
    (ex_ty * context) tzresult =
 fun ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract node ->
  Gas.consume ctxt Typecheck_costs.cycle
  >>? fun ctxt ->
  match node with
  | Prim (loc, T_unit, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Unit_t ty_name), ctxt)
  | Prim (loc, T_int, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Int_t ty_name), ctxt)
  | Prim (loc, T_nat, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Nat_t ty_name), ctxt)
  | Prim (loc, T_string, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (String_t ty_name), ctxt)
  | Prim (loc, T_bytes, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Bytes_t ty_name), ctxt)
  | Prim (loc, T_mutez, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Mutez_t ty_name), ctxt)
  | Prim (loc, T_bool, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Bool_t ty_name), ctxt)
  | Prim (loc, T_key, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Key_t ty_name), ctxt)
  | Prim (loc, T_key_hash, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Key_hash_t ty_name), ctxt)
  | Prim (loc, T_timestamp, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Timestamp_t ty_name), ctxt)
  | Prim (loc, T_address, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Address_t ty_name), ctxt)
  | Prim (loc, T_signature, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Signature_t ty_name), ctxt)
  | Prim (loc, T_operation, [], annot) ->
      if allow_operation then
        parse_type_annot loc annot
        >>? fun ty_name ->
        Gas.consume ctxt (Typecheck_costs.type_ 0)
        >|? fun ctxt -> (Ex_ty (Operation_t ty_name), ctxt)
      else error (Unexpected_operation loc)
  | Prim (loc, T_chain_id, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Chain_id_t ty_name), ctxt)
  | Prim (loc, T_contract, [utl], annot) ->
      if allow_contract then
        parse_parameter_ty ctxt ~legacy utl
        >>? fun (Ex_ty tl, ctxt) ->
        parse_type_annot loc annot
        >>? fun ty_name ->
        Gas.consume ctxt (Typecheck_costs.type_ 1)
        >|? fun ctxt -> (Ex_ty (Contract_t (tl, ty_name)), ctxt)
      else error (Unexpected_contract loc)
  | Prim (loc, T_pair, [utl; utr], annot) ->
      extract_field_annot utl
      >>? fun (utl, left_field) ->
      extract_field_annot utr
      >>? fun (utr, right_field) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl
      >>? fun (Ex_ty tl, ctxt) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr
      >>? fun (Ex_ty tr, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt ->
      ( Ex_ty
          (Pair_t
             ( (tl, left_field, None),
               (tr, right_field, None),
               ty_name,
               has_big_map tl || has_big_map tr )),
        ctxt )
  | Prim (loc, T_or, [utl; utr], annot) ->
      extract_field_annot utl
      >>? fun (utl, left_constr) ->
      extract_field_annot utr
      >>? fun (utr, right_constr) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl
      >>? fun (Ex_ty tl, ctxt) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr
      >>? fun (Ex_ty tr, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt ->
      ( Ex_ty
          (Union_t
             ( (tl, left_constr),
               (tr, right_constr),
               ty_name,
               has_big_map tl || has_big_map tr )),
        ctxt )
  | Prim (loc, T_lambda, [uta; utr], annot) ->
      parse_any_ty ctxt ~legacy uta
      >>? fun (Ex_ty ta, ctxt) ->
      parse_any_ty ctxt ~legacy utr
      >>? fun (Ex_ty tr, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt -> (Ex_ty (Lambda_t (ta, tr, ty_name)), ctxt)
  | Prim (loc, T_option, [ut], annot) ->
      ( if legacy then
        (* legacy semantics with (broken) field annotations *)
        extract_field_annot ut
        >>? fun (ut, _some_constr) ->
        parse_composed_type_annot loc annot
        >>? fun (ty_name, _none_constr, _) -> ok (ut, ty_name)
      else parse_type_annot loc annot >>? fun ty_name -> ok (ut, ty_name) )
      >>? fun (ut, ty_name) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut
      >>? fun (Ex_ty t, ctxt) ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt -> (Ex_ty (Option_t (t, ty_name, has_big_map t)), ctxt)
  | Prim (loc, T_list, [ut], annot) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut
      >>? fun (Ex_ty t, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 1)
      >|? fun ctxt -> (Ex_ty (List_t (t, ty_name, has_big_map t)), ctxt)
  | Prim (loc, T_set, [ut], annot) ->
      parse_comparable_ty ctxt ut
      >>? fun (Ex_comparable_ty t, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 1)
      >|? fun ctxt -> (Ex_ty (Set_t (t, ty_name)), ctxt)
  | Prim (loc, T_map, [uta; utr], annot) ->
      parse_comparable_ty ctxt uta
      >>? fun (Ex_comparable_ty ta, ctxt) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr
      >>? fun (Ex_ty tr, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt -> (Ex_ty (Map_t (ta, tr, ty_name, has_big_map tr)), ctxt)
  | Prim (loc, T_big_map, args, annot) when allow_big_map ->
      parse_big_map_ty ctxt ~legacy loc args annot
      >>? fun (big_map_ty, ctxt) ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt -> (big_map_ty, ctxt)
  | Prim (loc, T_big_map, _, _) ->
      error (Unexpected_big_map loc)
  | Prim
      ( loc,
        ( ( T_unit
          | T_signature
          | T_int
          | T_nat
          | T_string
          | T_bytes
          | T_mutez
          | T_bool
          | T_key
          | T_key_hash
          | T_timestamp
          | T_address ) as prim ),
        l,
        _ ) ->
      error (Invalid_arity (loc, prim, 0, List.length l))
  | Prim (loc, ((T_set | T_list | T_option | T_contract) as prim), l, _) ->
      error (Invalid_arity (loc, prim, 1, List.length l))
  | Prim (loc, ((T_pair | T_or | T_map | T_lambda) as prim), l, _) ->
      error (Invalid_arity (loc, prim, 2, List.length l))
  | expr ->
      error
      @@ unexpected
           expr
           []
           Type_namespace
           [ T_pair;
             T_or;
             T_set;
             T_map;
             T_list;
             T_option;
             T_lambda;
             T_unit;
             T_signature;
             T_contract;
             T_int;
             T_nat;
             T_operation;
             T_string;
             T_bytes;
             T_mutez;
             T_bool;
             T_key;
             T_key_hash;
             T_timestamp;
             T_chain_id ]

and parse_big_map_ty ctxt ~legacy big_map_loc args map_annot =
  Gas.consume ctxt Typecheck_costs.cycle
  >>? fun ctxt ->
  match args with
  | [key_ty; value_ty] ->
      parse_comparable_ty ctxt key_ty
      >>? fun (Ex_comparable_ty key_ty, ctxt) ->
      parse_packable_ty ctxt ~legacy value_ty
      >>? fun (Ex_ty value_ty, ctxt) ->
      parse_type_annot big_map_loc map_annot
      >|? fun map_name ->
      let big_map_ty = Big_map_t (key_ty, value_ty, map_name) in
      (Ex_ty big_map_ty, ctxt)
  | args ->
      error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args)

and parse_storage_ty :
    context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
 fun ctxt ~legacy node ->
  match node with
  | Prim
      ( loc,
        T_pair,
        [Prim (big_map_loc, T_big_map, args, map_annot); remaining_storage],
        storage_annot )
    when legacy -> (
    match storage_annot with
    | [] ->
        parse_ty
          ctxt
          ~legacy
          ~allow_big_map:true
          ~allow_operation:false
          ~allow_contract:legacy
          node
    | [single]
      when Compare.Int.(String.length single > 0)
           && Compare.Char.(single.[0] = '%') ->
        parse_ty
          ctxt
          ~legacy
          ~allow_big_map:true
          ~allow_operation:false
          ~allow_contract:legacy
          node
    | _ ->
        (* legacy semantics of big maps used the wrong annotation parser *)
        Gas.consume ctxt Typecheck_costs.cycle
        >>? fun ctxt ->
        parse_big_map_ty ctxt ~legacy big_map_loc args map_annot
        >>? fun (Ex_ty big_map_ty, ctxt) ->
        parse_ty
          ctxt
          ~legacy
          ~allow_big_map:true
          ~allow_operation:false
          ~allow_contract:legacy
          remaining_storage
        >>? fun (Ex_ty remaining_storage, ctxt) ->
        parse_composed_type_annot loc storage_annot
        >>? fun (ty_name, map_field, storage_field) ->
        Gas.consume ctxt (Typecheck_costs.type_ 5)
        >|? fun ctxt ->
        ( Ex_ty
            (Pair_t
               ( (big_map_ty, map_field, None),
                 (remaining_storage, storage_field, None),
                 ty_name,
                 true )),
          ctxt ) )
  | _ ->
      parse_ty
        ctxt
        ~legacy
        ~allow_big_map:true
        ~allow_operation:false
        ~allow_contract:legacy
        node

let check_packable ~legacy loc root =
  let rec check : type t. t ty -> unit tzresult = function
    | Big_map_t _ ->
        error (Unexpected_big_map loc)
    | Operation_t _ ->
        error (Unexpected_operation loc)
    | Unit_t _ ->
        ok ()
    | Int_t _ ->
        ok ()
    | Nat_t _ ->
        ok ()
    | Signature_t _ ->
        ok ()
    | String_t _ ->
        ok ()
    | Bytes_t _ ->
        ok ()
    | Mutez_t _ ->
        ok ()
    | Key_hash_t _ ->
        ok ()
    | Key_t _ ->
        ok ()
    | Timestamp_t _ ->
        ok ()
    | Address_t _ ->
        ok ()
    | Bool_t _ ->
        ok ()
    | Chain_id_t _ ->
        ok ()
    | Pair_t ((l_ty, _, _), (r_ty, _, _), _, _) ->
        check l_ty >>? fun () -> check r_ty
    | Union_t ((l_ty, _), (r_ty, _), _, _) ->
        check l_ty >>? fun () -> check r_ty
    | Option_t (v_ty, _, _) ->
        check v_ty
    | List_t (elt_ty, _, _) ->
        check elt_ty
    | Set_t (_, _) ->
        ok ()
    | Map_t (_, elt_ty, _, _) ->
        check elt_ty
    | Lambda_t (_l_ty, _r_ty, _) ->
        ok ()
    | Contract_t (_, _) when legacy ->
        ok ()
    | Contract_t (_, _) ->
        error (Unexpected_contract loc)
  in
  check root

type ex_script = Ex_script : ('a, 'c) script -> ex_script

type _ dig_proof_argument =
  | Dig_proof_argument :
      ( ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness
      * ('x ty * var_annot option)
      * 'aft stack_ty )
      -> 'bef dig_proof_argument

type (_, _) dug_proof_argument =
  | Dug_proof_argument :
      ( ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness
      * unit
      * 'aft stack_ty )
      -> ('bef, 'x) dug_proof_argument

type _ dipn_proof_argument =
  | Dipn_proof_argument :
      ( ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness
      * (context * ('fbef, 'faft) descr)
      * 'aft stack_ty )
      -> 'bef dipn_proof_argument

type _ dropn_proof_argument =
  | Dropn_proof_argument :
      ( ('rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness
      * 'rest stack_ty
      * 'aft stack_ty )
      -> 'bef dropn_proof_argument

(* Lwt versions *)
let parse_var_annot loc ?default annot =
  Lwt.return (parse_var_annot loc ?default annot)

let parse_entrypoint_annot loc ?default annot =
  Lwt.return (parse_entrypoint_annot loc ?default annot)

let parse_constr_annot loc ?if_special_first ?if_special_second annot =
  Lwt.return
    (parse_constr_annot loc ?if_special_first ?if_special_second annot)

let parse_two_var_annot loc annot = Lwt.return (parse_two_var_annot loc annot)

let parse_destr_annot loc annot ~default_accessor ~field_name ~pair_annot
    ~value_annot =
  Lwt.return
    (parse_destr_annot
       loc
       annot
       ~default_accessor
       ~field_name
       ~pair_annot
       ~value_annot)

let parse_var_type_annot loc annot =
  Lwt.return (parse_var_type_annot loc annot)

let find_entrypoint (type full) (full : full ty) ~root_name entrypoint =
  let rec find_entrypoint :
      type t. t ty -> string -> (Script.node -> Script.node) * ex_ty =
   fun t entrypoint ->
    match t with
    | Union_t ((tl, al), (tr, ar), _, _) -> (
        if
          match al with
          | None ->
              false
          | Some (`Field_annot l) ->
              Compare.String.(l = entrypoint)
        then ((fun e -> Prim (0, D_Left, [e], [])), Ex_ty tl)
        else if
          match ar with
          | None ->
              false
          | Some (`Field_annot r) ->
              Compare.String.(r = entrypoint)
        then ((fun e -> Prim (0, D_Right, [e], [])), Ex_ty tr)
        else
          try
            let (f, t) = find_entrypoint tl entrypoint in
            ((fun e -> Prim (0, D_Left, [f e], [])), t)
          with Not_found ->
            let (f, t) = find_entrypoint tr entrypoint in
            ((fun e -> Prim (0, D_Right, [f e], [])), t) )
    | _ ->
        raise Not_found
  in
  let entrypoint =
    if Compare.String.(entrypoint = "") then "default" else entrypoint
  in
  if Compare.Int.(String.length entrypoint > 31) then
    error (Entrypoint_name_too_long entrypoint)
  else
    match root_name with
    | Some root_name when Compare.String.(entrypoint = root_name) ->
        ok ((fun e -> e), Ex_ty full)
    | _ -> (
      try ok (find_entrypoint full entrypoint)
      with Not_found -> (
        match entrypoint with
        | "default" ->
            ok ((fun e -> e), Ex_ty full)
        | _ ->
            error (No_such_entrypoint entrypoint) ) )

let find_entrypoint_for_type (type full exp) ~(full : full ty)
    ~(expected : exp ty) ~root_name entrypoint ctxt :
    (context * string * exp ty) tzresult =
  match (entrypoint, root_name) with
  | ("default", Some "root") -> (
    match find_entrypoint full ~root_name entrypoint with
    | Error _ as err ->
        err
    | Ok (_, Ex_ty ty) -> (
      match ty_eq ctxt expected ty with
      | Ok (Eq, ctxt) ->
          ok (ctxt, "default", (ty : exp ty))
      | Error _ ->
          ty_eq ctxt expected full
          >>? fun (Eq, ctxt) -> ok (ctxt, "root", (full : exp ty)) ) )
  | _ ->
      find_entrypoint full ~root_name entrypoint
      >>? fun (_, Ex_ty ty) ->
      ty_eq ctxt expected ty
      >>? fun (Eq, ctxt) -> ok (ctxt, entrypoint, (ty : exp ty))

module Entrypoints = Set.Make (String)

exception Duplicate of string

exception Too_long of string

let well_formed_entrypoints (type full) (full : full ty) ~root_name =
  let merge path annot (type t) (ty : t ty) reachable
      ((first_unreachable, all) as acc) =
    match annot with
    | None | Some (`Field_annot "") -> (
        if reachable then acc
        else
          match ty with
          | Union_t _ ->
              acc
          | _ -> (
            match first_unreachable with
            | None ->
                (Some (List.rev path), all)
            | Some _ ->
                acc ) )
    | Some (`Field_annot name) ->
        if Compare.Int.(String.length name > 31) then raise (Too_long name)
        else if Entrypoints.mem name all then raise (Duplicate name)
        else (first_unreachable, Entrypoints.add name all)
  in
  let rec check :
      type t.
      t ty ->
      prim list ->
      bool ->
      prim list option * Entrypoints.t ->
      prim list option * Entrypoints.t =
   fun t path reachable acc ->
    match t with
    | Union_t ((tl, al), (tr, ar), _, _) ->
        let acc = merge (D_Left :: path) al tl reachable acc in
        let acc = merge (D_Right :: path) ar tr reachable acc in
        let acc =
          check
            tl
            (D_Left :: path)
            (match al with Some _ -> true | None -> reachable)
            acc
        in
        check
          tr
          (D_Right :: path)
          (match ar with Some _ -> true | None -> reachable)
          acc
    | _ ->
        acc
  in
  try
    let (init, reachable) =
      match root_name with
      | None | Some "" ->
          (Entrypoints.empty, false)
      | Some name ->
          (Entrypoints.singleton name, true)
    in
    let (first_unreachable, all) = check full [] reachable (None, init) in
    if not (Entrypoints.mem "default" all) then ok ()
    else
      match first_unreachable with
      | None ->
          ok ()
      | Some path ->
          error (Unreachable_entrypoint path)
  with
  | Duplicate name ->
      error (Duplicate_entrypoint name)
  | Too_long name ->
      error (Entrypoint_name_too_long name)

let rec parse_data :
    type a.
    ?type_logger:type_logger ->
    context ->
    legacy:bool ->
    a ty ->
    Script.node ->
    (a * context) tzresult Lwt.t =
 fun ?type_logger ctxt ~legacy ty script_data ->
  Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
  >>=? fun ctxt ->
  let error () =
    Lwt.return (serialize_ty_for_error ctxt ty)
    >>|? fun (ty, _ctxt) ->
    Invalid_constant (location script_data, strip_locations script_data, ty)
  in
  let traced body = trace_eval error body in
  let parse_items ?type_logger loc ctxt expr key_type value_type items
      item_wrapper =
    let length = List.length items in
    fold_left_s
      (fun (last_value, map, ctxt) item ->
        Lwt.return (Gas.consume ctxt (Typecheck_costs.map_element length))
        >>=? fun ctxt ->
        match item with
        | Prim (_, D_Elt, [k; v], _) ->
            parse_comparable_data ?type_logger ctxt key_type k
            >>=? fun (k, ctxt) ->
            parse_data ?type_logger ctxt ~legacy value_type v
            >>=? fun (v, ctxt) ->
            ( match last_value with
            | Some value ->
                if Compare.Int.(0 <= compare_comparable key_type value k) then
                  if Compare.Int.(0 = compare_comparable key_type value k) then
                    fail (Duplicate_map_keys (loc, strip_locations expr))
                  else fail (Unordered_map_keys (loc, strip_locations expr))
                else return_unit
            | None ->
                return_unit )
            >>=? fun () ->
            return (Some k, map_update k (Some (item_wrapper v)) map, ctxt)
        | Prim (loc, D_Elt, l, _) ->
            fail @@ Invalid_arity (loc, D_Elt, 2, List.length l)
        | Prim (loc, name, _, _) ->
            fail @@ Invalid_primitive (loc, [D_Elt], name)
        | Int _ | String _ | Bytes _ | Seq _ ->
            error () >>=? fail)
      (None, empty_map key_type, ctxt)
      items
    |> traced
    >>|? fun (_, items, ctxt) -> (items, ctxt)
  in
  match (ty, script_data) with
  (* Unit *)
  | (Unit_t _, Prim (loc, D_Unit, [], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.unit)
      >>|? fun ctxt -> ((() : a), ctxt)
  | (Unit_t _, Prim (loc, D_Unit, l, _)) ->
      traced (fail (Invalid_arity (loc, D_Unit, 0, List.length l)))
  | (Unit_t _, expr) ->
      traced (fail (unexpected expr [] Constant_namespace [D_Unit]))
  (* Booleans *)
  | (Bool_t _, Prim (loc, D_True, [], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.bool)
      >>|? fun ctxt -> (true, ctxt)
  | (Bool_t _, Prim (loc, D_False, [], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.bool)
      >>|? fun ctxt -> (false, ctxt)
  | (Bool_t _, Prim (loc, ((D_True | D_False) as c), l, _)) ->
      traced (fail (Invalid_arity (loc, c, 0, List.length l)))
  | (Bool_t _, expr) ->
      traced (fail (unexpected expr [] Constant_namespace [D_True; D_False]))
  (* Strings *)
  | (String_t _, String (_, v)) ->
      Lwt.return (Gas.consume ctxt (Typecheck_costs.string (String.length v)))
      >>=? fun ctxt ->
      let rec check_printable_ascii i =
        if Compare.Int.(i < 0) then true
        else
          match v.[i] with
          | '\n' | '\x20' .. '\x7E' ->
              check_printable_ascii (i - 1)
          | _ ->
              false
      in
      if check_printable_ascii (String.length v - 1) then return (v, ctxt)
      else error () >>=? fail
  | (String_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [String_kind], kind expr)))
  (* Byte sequences *)
  | (Bytes_t _, Bytes (_, v)) ->
      Lwt.return (Gas.consume ctxt (Typecheck_costs.string (MBytes.length v)))
      >>=? fun ctxt -> return (v, ctxt)
  | (Bytes_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Bytes_kind], kind expr)))
  (* Integers *)
  | (Int_t _, Int (_, v)) ->
      Lwt.return (Gas.consume ctxt (Typecheck_costs.z v))
      >>=? fun ctxt -> return (Script_int.of_zint v, ctxt)
  | (Nat_t _, Int (_, v)) ->
      Lwt.return (Gas.consume ctxt (Typecheck_costs.z v))
      >>=? fun ctxt ->
      let v = Script_int.of_zint v in
      if Compare.Int.(Script_int.compare v Script_int.zero >= 0) then
        return (Script_int.abs v, ctxt)
      else error () >>=? fail
  | (Int_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Int_kind], kind expr)))
  | (Nat_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Int_kind], kind expr)))
  (* Tez amounts *)
  | (Mutez_t _, Int (_, v)) -> (
      Lwt.return
        ( Gas.consume ctxt Typecheck_costs.tez
        >>? fun ctxt ->
        Gas.consume ctxt Michelson_v1_gas.Cost_of.Legacy.z_to_int64 )
      >>=? fun ctxt ->
      try
        match Tez.of_mutez (Z.to_int64 v) with
        | None ->
            raise Exit
        | Some tez ->
            return (tez, ctxt)
      with _ -> error () >>=? fail )
  | (Mutez_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Int_kind], kind expr)))
  (* Timestamps *)
  | (Timestamp_t _, Int (_, v))
  (* As unparsed with [Optimized] or out of bounds [Readable]. *) ->
      Lwt.return (Gas.consume ctxt (Typecheck_costs.z v))
      >>=? fun ctxt -> return (Script_timestamp.of_zint v, ctxt)
  | (Timestamp_t _, String (_, s)) (* As unparsed with [Redable]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.string_timestamp)
      >>=? fun ctxt ->
      match Script_timestamp.of_string s with
      | Some v ->
          return (v, ctxt)
      | None ->
          error () >>=? fail )
  | (Timestamp_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Int_kind], kind expr)))
  (* IDs *)
  | (Key_t _, Bytes (_, bytes)) -> (
      (* As unparsed with [Optimized]. *)
      Lwt.return (Gas.consume ctxt Typecheck_costs.key)
      >>=? fun ctxt ->
      match
        Data_encoding.Binary.of_bytes Signature.Public_key.encoding bytes
      with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Key_t _, String (_, s)) -> (
      (* As unparsed with [Readable]. *)
      Lwt.return (Gas.consume ctxt Typecheck_costs.key)
      >>=? fun ctxt ->
      match Signature.Public_key.of_b58check_opt s with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Key_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  | (Key_hash_t _, Bytes (_, bytes)) -> (
      (* As unparsed with [Optimized]. *)
      Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash)
      >>=? fun ctxt ->
      match
        Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding bytes
      with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Key_hash_t _, String (_, s)) (* As unparsed with [Readable]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash)
      >>=? fun ctxt ->
      match Signature.Public_key_hash.of_b58check_opt s with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Key_hash_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  (* Signatures *)
  | (Signature_t _, Bytes (_, bytes)) (* As unparsed with [Optimized]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.signature)
      >>=? fun ctxt ->
      match Data_encoding.Binary.of_bytes Signature.encoding bytes with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Signature_t _, String (_, s)) (* As unparsed with [Readable]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.signature)
      >>=? fun ctxt ->
      match Signature.of_b58check_opt s with
      | Some s ->
          return (s, ctxt)
      | None ->
          error () >>=? fail )
  | (Signature_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  (* Operations *)
  | (Operation_t _, _) ->
      (* operations cannot appear in parameters or storage,
           the protocol should never parse the bytes of an operation *)
      assert false
  (* Chain_ids *)
  | (Chain_id_t _, Bytes (_, bytes)) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id)
      >>=? fun ctxt ->
      match Data_encoding.Binary.of_bytes Chain_id.encoding bytes with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Chain_id_t _, String (_, s)) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id)
      >>=? fun ctxt ->
      match Chain_id.of_b58check_opt s with
      | Some s ->
          return (s, ctxt)
      | None ->
          error () >>=? fail )
  | (Chain_id_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  (* Addresses *)
  | (Address_t _, Bytes (loc, bytes)) (* As unparsed with [O[ptimized]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
      >>=? fun ctxt ->
      match
        Data_encoding.Binary.of_bytes
          Data_encoding.(tup2 Contract.encoding Variable.string)
          bytes
      with
      | Some (c, entrypoint) ->
          if Compare.Int.(String.length entrypoint > 31) then
            fail (Entrypoint_name_too_long entrypoint)
          else
            ( match entrypoint with
            | "" ->
                return "default"
            | "default" ->
                fail (Unexpected_annotation loc)
            | name ->
                return name )
            >>=? fun entrypoint -> return ((c, entrypoint), ctxt)
      | None ->
          error () >>=? fail )
  | (Address_t _, String (loc, s)) (* As unparsed with [Readable]. *) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
      >>=? fun ctxt ->
      ( match String.index_opt s '%' with
      | None ->
          return (s, "default")
      | Some pos -> (
          let len = String.length s - pos - 1 in
          let name = String.sub s (pos + 1) len in
          if Compare.Int.(len > 31) then fail (Entrypoint_name_too_long name)
          else
            match (String.sub s 0 pos, name) with
            | (_, "default") ->
                traced (fail (Unexpected_annotation loc))
            | addr_and_name ->
                return addr_and_name ) )
      >>=? fun (addr, entrypoint) ->
      Lwt.return (Contract.of_b58check addr)
      >>=? fun c -> return ((c, entrypoint), ctxt)
  | (Address_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  (* Contracts *)
  | (Contract_t (ty, _), Bytes (loc, bytes))
  (* As unparsed with [Optimized]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
      >>=? fun ctxt ->
      match
        Data_encoding.Binary.of_bytes
          Data_encoding.(tup2 Contract.encoding Variable.string)
          bytes
      with
      | Some (c, entrypoint) ->
          if Compare.Int.(String.length entrypoint > 31) then
            fail (Entrypoint_name_too_long entrypoint)
          else
            ( match entrypoint with
            | "" ->
                return "default"
            | "default" ->
                traced (fail (Unexpected_annotation loc))
            | name ->
                return name )
            >>=? fun entrypoint ->
            traced (parse_contract ~legacy ctxt loc ty c ~entrypoint)
            >>=? fun (ctxt, _) -> return ((ty, (c, entrypoint)), ctxt)
      | None ->
          error () >>=? fail )
  | (Contract_t (ty, _), String (loc, s)) (* As unparsed with [Readable]. *) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
      >>=? fun ctxt ->
      ( match String.index_opt s '%' with
      | None ->
          return (s, "default")
      | Some pos -> (
          let len = String.length s - pos - 1 in
          let name = String.sub s (pos + 1) len in
          if Compare.Int.(len > 31) then fail (Entrypoint_name_too_long name)
          else
            match (String.sub s 0 pos, name) with
            | (_, "default") ->
                traced (fail (Unexpected_annotation loc))
            | addr_and_name ->
                return addr_and_name ) )
      >>=? fun (addr, entrypoint) ->
      traced (Lwt.return (Contract.of_b58check addr))
      >>=? fun c ->
      parse_contract ~legacy ctxt loc ty c ~entrypoint
      >>=? fun (ctxt, _) -> return ((ty, (c, entrypoint)), ctxt)
  | (Contract_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  (* Pairs *)
  | (Pair_t ((ta, _, _), (tb, _, _), _, _), Prim (loc, D_Pair, [va; vb], annot))
    ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.pair)
      >>=? fun ctxt ->
      traced @@ parse_data ?type_logger ctxt ~legacy ta va
      >>=? fun (va, ctxt) ->
      parse_data ?type_logger ctxt ~legacy tb vb
      >>=? fun (vb, ctxt) -> return ((va, vb), ctxt)
  | (Pair_t _, Prim (loc, D_Pair, l, _)) ->
      fail @@ Invalid_arity (loc, D_Pair, 2, List.length l)
  | (Pair_t _, expr) ->
      traced (fail (unexpected expr [] Constant_namespace [D_Pair]))
  (* Unions *)
  | (Union_t ((tl, _), _, _, _), Prim (loc, D_Left, [v], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.union)
      >>=? fun ctxt ->
      traced @@ parse_data ?type_logger ctxt ~legacy tl v
      >>=? fun (v, ctxt) -> return (L v, ctxt)
  | (Union_t _, Prim (loc, D_Left, l, _)) ->
      fail @@ Invalid_arity (loc, D_Left, 1, List.length l)
  | (Union_t (_, (tr, _), _, _), Prim (loc, D_Right, [v], annot)) ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.union)
      >>=? fun ctxt ->
      traced @@ parse_data ?type_logger ctxt ~legacy tr v
      >>=? fun (v, ctxt) -> return (R v, ctxt)
  | (Union_t _, Prim (loc, D_Right, l, _)) ->
      fail @@ Invalid_arity (loc, D_Right, 1, List.length l)
  | (Union_t _, expr) ->
      traced (fail (unexpected expr [] Constant_namespace [D_Left; D_Right]))
  (* Lambdas *)
  | (Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr)) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.lambda)
      >>=? fun ctxt ->
      traced
      @@ parse_returning
           Lambda
           ?type_logger
           ctxt
           ~legacy
           (ta, Some (`Var_annot "@arg"))
           tr
           script_instr
  | (Lambda_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
  (* Options *)
  | (Option_t (t, _, _), Prim (loc, D_Some, [v], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.some)
      >>=? fun ctxt ->
      traced @@ parse_data ?type_logger ctxt ~legacy t v
      >>=? fun (v, ctxt) -> return (Some v, ctxt)
  | (Option_t _, Prim (loc, D_Some, l, _)) ->
      fail @@ Invalid_arity (loc, D_Some, 1, List.length l)
  | (Option_t (_, _, _), Prim (loc, D_None, [], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.none)
      >>=? fun ctxt -> return (None, ctxt)
  | (Option_t _, Prim (loc, D_None, l, _)) ->
      fail @@ Invalid_arity (loc, D_None, 0, List.length l)
  | (Option_t _, expr) ->
      traced (fail (unexpected expr [] Constant_namespace [D_Some; D_None]))
  (* Lists *)
  | (List_t (t, _ty_name, _), Seq (_loc, items)) ->
      traced
      @@ fold_right_s
           (fun v (rest, ctxt) ->
             Lwt.return (Gas.consume ctxt Typecheck_costs.list_element)
             >>=? fun ctxt ->
             parse_data ?type_logger ctxt ~legacy t v
             >>=? fun (v, ctxt) -> return (v :: rest, ctxt))
           items
           ([], ctxt)
  | (List_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
  (* Sets *)
  | (Set_t (t, _ty_name), (Seq (loc, vs) as expr)) ->
      let length = List.length vs in
      traced
      @@ fold_left_s
           (fun (last_value, set, ctxt) v ->
             Lwt.return (Gas.consume ctxt (Typecheck_costs.set_element length))
             >>=? fun ctxt ->
             parse_comparable_data ?type_logger ctxt t v
             >>=? fun (v, ctxt) ->
             ( match last_value with
             | Some value ->
                 if Compare.Int.(0 <= compare_comparable t value v) then
                   if Compare.Int.(0 = compare_comparable t value v) then
                     fail (Duplicate_set_values (loc, strip_locations expr))
                   else fail (Unordered_set_values (loc, strip_locations expr))
                 else return_unit
             | None ->
                 return_unit )
             >>=? fun () ->
             Lwt.return
               (Gas.consume
                  ctxt
                  (Michelson_v1_gas.Cost_of.Legacy.set_update v false set))
             >>=? fun ctxt -> return (Some v, set_update v true set, ctxt))
           (None, empty_set t, ctxt)
           vs
      >>|? fun (_, set, ctxt) -> (set, ctxt)
  | (Set_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
  (* Maps *)
  | (Map_t (tk, tv, _ty_name, _), (Seq (loc, vs) as expr)) ->
      parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x)
  | (Map_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
  | (Big_map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr)) ->
      parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x)
      >>|? fun (diff, ctxt) ->
      ( {id = None; diff; key_type = ty_of_comparable_ty tk; value_type = tv},
        ctxt )
  | (Big_map_t (tk, tv, _ty_name), Int (loc, id)) -> (
      Big_map.exists ctxt id
      >>=? function
      | (_, None) ->
          traced (fail (Invalid_big_map (loc, id)))
      | (ctxt, Some (btk, btv)) ->
          Lwt.return
            ( parse_comparable_ty ctxt (Micheline.root btk)
            >>? fun (Ex_comparable_ty btk, ctxt) ->
            parse_packable_ty ctxt ~legacy (Micheline.root btv)
            >>? fun (Ex_ty btv, ctxt) ->
            comparable_ty_eq ctxt tk btk
            >>? fun Eq ->
            ty_eq ctxt tv btv
            >>? fun (Eq, ctxt) ->
            ok
              ( {
                  id = Some id;
                  diff = empty_map tk;
                  key_type = ty_of_comparable_ty tk;
                  value_type = tv;
                },
                ctxt ) ) )
  | (Big_map_t (_tk, _tv, _), expr) ->
      traced
        (fail (Invalid_kind (location expr, [Seq_kind; Int_kind], kind expr)))

and parse_comparable_data :
    type a.
    ?type_logger:type_logger ->
    context ->
    a comparable_ty ->
    Script.node ->
    (a * context) tzresult Lwt.t =
 fun ?type_logger ctxt ty script_data ->
  parse_data
    ?type_logger
    ctxt
    ~legacy:false
    (ty_of_comparable_ty ty)
    script_data

and parse_returning :
    type arg ret.
    ?type_logger:type_logger ->
    tc_context ->
    context ->
    legacy:bool ->
    arg ty * var_annot option ->
    ret ty ->
    Script.node ->
    ((arg, ret) lambda * context) tzresult Lwt.t =
 fun ?type_logger tc_context ctxt ~legacy (arg, arg_annot) ret script_instr ->
  parse_instr
    ?type_logger
    tc_context
    ctxt
    ~legacy
    script_instr
    (Item_t (arg, Empty_t, arg_annot))
  >>=? function
  | (Typed ({loc; aft = Item_t (ty, Empty_t, _) as stack_ty; _} as descr), ctxt)
    ->
      trace_eval
        (fun () ->
          Lwt.return (serialize_ty_for_error ctxt ret)
          >>=? fun (ret, ctxt) ->
          serialize_stack_for_error ctxt stack_ty
          >>|? fun (stack_ty, _ctxt) -> Bad_return (loc, stack_ty, ret))
        ( Lwt.return (ty_eq ctxt ty ret)
        >>=? fun (Eq, ctxt) ->
        Lwt.return (merge_types ~legacy ctxt loc ty ret)
        >>=? fun (_ret, ctxt) ->
        return ((Lam (descr, script_instr) : (arg, ret) lambda), ctxt) )
  | (Typed {loc; aft = stack_ty; _}, ctxt) ->
      Lwt.return (serialize_ty_for_error ctxt ret)
      >>=? fun (ret, ctxt) ->
      serialize_stack_for_error ctxt stack_ty
      >>=? fun (stack_ty, _ctxt) -> fail (Bad_return (loc, stack_ty, ret))
  | (Failed {descr}, ctxt) ->
      return
        ( ( Lam (descr (Item_t (ret, Empty_t, None)), script_instr)
            : (arg, ret) lambda ),
          ctxt )

and parse_int32 (n : (location, prim) Micheline.node) : int tzresult =
  let error' () =
    Invalid_syntactic_constant
      ( location n,
        strip_locations n,
        "a positive 32-bit integer (between 0 and "
        ^ Int32.to_string Int32.max_int
        ^ ")" )
  in
  match n with
  | Micheline.Int (_, n') -> (
    try
      let n'' = Z.to_int n' in
      if
        Compare.Int.(0 <= n'')
        && Compare.Int.(n'' <= Int32.to_int Int32.max_int)
      then ok n''
      else error @@ error' ()
    with _ -> error @@ error' () )
  | _ ->
      error @@ error' ()

and parse_instr :
    type bef.
    ?type_logger:type_logger ->
    tc_context ->
    context ->
    legacy:bool ->
    Script.node ->
    bef stack_ty ->
    (bef judgement * context) tzresult Lwt.t =
 fun ?type_logger tc_context ctxt ~legacy script_instr stack_ty ->
  let _check_item check loc name n m =
    trace_eval (fun () ->
        serialize_stack_for_error ctxt stack_ty
        >>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty))
    @@ trace (Bad_stack_item n) @@ Lwt.return check
  in
  let check_item_ty (type a b) ctxt (exp : a ty) (got : b ty) loc name n m :
      ((a, b) eq * a ty * context) tzresult Lwt.t =
    trace_eval (fun () ->
        serialize_stack_for_error ctxt stack_ty
        >>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty))
    @@ trace (Bad_stack_item n)
    @@ Lwt.return
         ( ty_eq ctxt exp got
         >>? fun (Eq, ctxt) ->
         merge_types ~legacy ctxt loc exp got
         >>? fun (ty, ctxt) -> ok ((Eq : (a, b) eq), (ty : a ty), ctxt) )
  in
  let check_item_comparable_ty (type a b) (exp : a comparable_ty)
      (got : b comparable_ty) loc name n m :
      ((a, b) eq * a comparable_ty) tzresult Lwt.t =
    trace_eval (fun () ->
        serialize_stack_for_error ctxt stack_ty
        >>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty))
    @@ trace (Bad_stack_item n)
    @@ Lwt.return
         ( comparable_ty_eq ctxt exp got
         >>? fun Eq ->
         merge_comparable_types ~legacy exp got
         >>? fun ty -> ok ((Eq : (a, b) eq), (ty : a comparable_ty)) )
  in
  let log_stack ctxt loc stack_ty aft =
    match (type_logger, script_instr) with
    | (None, _) | (Some _, (Seq (-1, _) | Int _ | String _ | Bytes _)) ->
        return_unit
    | (Some log, (Prim _ | Seq _)) ->
        (* Unparsing for logging done in an unlimited context as this
             is used only by the client and not the protocol *)
        let ctxt = Gas.set_unlimited ctxt in
        unparse_stack ctxt stack_ty
        >>=? fun (stack_ty, _) ->
        unparse_stack ctxt aft
        >>=? fun (aft, _) -> log loc stack_ty aft ; return_unit
  in
  let outer_return = return in
  let return :
      type bef.
      context -> bef judgement -> (bef judgement * context) tzresult Lwt.t =
   fun ctxt judgement ->
    match judgement with
    | Typed {instr; loc; aft; _} ->
        let maximum_type_size = Constants.michelson_maximum_type_size ctxt in
        let type_size =
          type_size_of_stack_head
            aft
            ~up_to:(number_of_generated_growing_types instr)
        in
        if Compare.Int.(type_size > maximum_type_size) then
          fail (Type_too_large (loc, type_size, maximum_type_size))
        else return (judgement, ctxt)
    | Failed _ ->
        return (judgement, ctxt)
  in
  let typed ctxt loc instr aft =
    log_stack ctxt loc stack_ty aft
    >>=? fun () ->
    Lwt.return @@ Gas.consume ctxt (Typecheck_costs.instr instr)
    >>=? fun ctxt -> return ctxt (Typed {loc; instr; bef = stack_ty; aft})
  in
  Lwt.return @@ Gas.consume ctxt Typecheck_costs.cycle
  >>=? fun ctxt ->
  match (script_instr, stack_ty) with
  (* stack ops *)
  | (Prim (loc, I_DROP, [], annot), Item_t (_, rest, _)) ->
      ( fail_unexpected_annot loc annot >>=? fun () -> typed ctxt loc Drop rest
        : (bef judgement * context) tzresult Lwt.t )
  | (Prim (loc, I_DROP, [n], result_annot), whole_stack) ->
      Lwt.return (parse_int32 n)
      >>=? fun whole_n ->
      let rec make_proof_argument :
          type tstk.
          int -> tstk stack_ty -> tstk dropn_proof_argument tzresult Lwt.t =
       fun n stk ->
        match (Compare.Int.(n = 0), stk) with
        | (true, rest) ->
            outer_return @@ Dropn_proof_argument (Rest, rest, rest)
        | (false, Item_t (v, rest, annot)) ->
            make_proof_argument (n - 1) rest
            >>=? fun (Dropn_proof_argument (n', stack_after_drops, aft')) ->
            outer_return
            @@ Dropn_proof_argument
                 (Prefix n', stack_after_drops, Item_t (v, aft', annot))
        | (_, _) ->
            serialize_stack_for_error ctxt whole_stack
            >>=? fun (whole_stack, _ctxt) ->
            fail (Bad_stack (loc, I_DROP, whole_n, whole_stack))
      in
      fail_unexpected_annot loc result_annot
      >>=? fun () ->
      make_proof_argument whole_n whole_stack
      >>=? fun (Dropn_proof_argument (n', stack_after_drops, _aft)) ->
      typed ctxt loc (Dropn (whole_n, n')) stack_after_drops
  | (Prim (loc, I_DROP, (_ :: _ :: _ as l), _), _) ->
      (* Technically, the arities 0 and 1 are allowed but the error only mentions 1.
           However, DROP is equivalent to DROP 1 so hinting at an arity of 1 makes sense. *)
      fail (Invalid_arity (loc, I_DROP, 1, List.length l))
  | (Prim (loc, I_DUP, [], annot), Item_t (v, rest, stack_annot)) ->
      parse_var_annot loc annot ~default:stack_annot
      >>=? fun annot ->
      typed ctxt loc Dup (Item_t (v, Item_t (v, rest, stack_annot), annot))
  | (Prim (loc, I_DIG, [n], result_annot), stack) ->
      let rec make_proof_argument :
          type tstk.
          int -> tstk stack_ty -> tstk dig_proof_argument tzresult Lwt.t =
       fun n stk ->
        match (Compare.Int.(n = 0), stk) with
        | (true, Item_t (v, rest, annot)) ->
            outer_return @@ Dig_proof_argument (Rest, (v, annot), rest)
        | (false, Item_t (v, rest, annot)) ->
            make_proof_argument (n - 1) rest
            >>=? fun (Dig_proof_argument (n', (x, xv), aft')) ->
            outer_return
            @@ Dig_proof_argument (Prefix n', (x, xv), Item_t (v, aft', annot))
        | (_, _) ->
            serialize_stack_for_error ctxt stack
            >>=? fun (whole_stack, _ctxt) ->
            fail (Bad_stack (loc, I_DIG, 1, whole_stack))
      in
      Lwt.return (parse_int32 n)
      >>=? fun n ->
      fail_unexpected_annot loc result_annot
      >>=? fun () ->
      make_proof_argument n stack
      >>=? fun (Dig_proof_argument (n', (x, stack_annot), aft)) ->
      typed ctxt loc (Dig (n, n')) (Item_t (x, aft, stack_annot))
  | (Prim (loc, I_DIG, (([] | _ :: _ :: _) as l), _), _) ->
      fail (Invalid_arity (loc, I_DIG, 1, List.length l))
  | (Prim (loc, I_DUG, [n], result_annot), Item_t (x, whole_stack, stack_annot))
    ->
      Lwt.return (parse_int32 n)
      >>=? fun whole_n ->
      let rec make_proof_argument :
          type tstk x.
          int ->
          x ty ->
          var_annot option ->
          tstk stack_ty ->
          (tstk, x) dug_proof_argument tzresult Lwt.t =
       fun n x stack_annot stk ->
        match (Compare.Int.(n = 0), stk) with
        | (true, rest) ->
            outer_return
            @@ Dug_proof_argument (Rest, (), Item_t (x, rest, stack_annot))
        | (false, Item_t (v, rest, annot)) ->
            make_proof_argument (n - 1) x stack_annot rest
            >>=? fun (Dug_proof_argument (n', (), aft')) ->
            outer_return
            @@ Dug_proof_argument (Prefix n', (), Item_t (v, aft', annot))
        | (_, _) ->
            serialize_stack_for_error ctxt whole_stack
            >>=? fun (whole_stack, _ctxt) ->
            fail (Bad_stack (loc, I_DUG, whole_n, whole_stack))
      in
      fail_unexpected_annot loc result_annot
      >>=? fun () ->
      make_proof_argument whole_n x stack_annot whole_stack
      >>=? fun (Dug_proof_argument (n', (), aft)) ->
      typed ctxt loc (Dug (whole_n, n')) aft
  | (Prim (loc, I_DUG, [_], result_annot), (Empty_t as stack)) ->
      fail_unexpected_annot loc result_annot
      >>=? fun () ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, I_DUG, 1, stack))
  | (Prim (loc, I_DUG, (([] | _ :: _ :: _) as l), _), _) ->
      fail (Invalid_arity (loc, I_DUG, 1, List.length l))
  | ( Prim (loc, I_SWAP, [], annot),
      Item_t (v, Item_t (w, rest, stack_annot), cur_top_annot) ) ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      typed
        ctxt
        loc
        Swap
        (Item_t (w, Item_t (v, rest, cur_top_annot), stack_annot))
  | (Prim (loc, I_PUSH, [t; d], annot), stack) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ parse_packable_ty ctxt ~legacy t
      >>=? fun (Ex_ty t, ctxt) ->
      parse_data ?type_logger ctxt ~legacy t d
      >>=? fun (v, ctxt) -> typed ctxt loc (Const v) (Item_t (t, stack, annot))
  | (Prim (loc, I_UNIT, [], annot), stack) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed ctxt loc (Const ()) (Item_t (Unit_t ty_name, stack, annot))
  (* options *)
  | (Prim (loc, I_SOME, [], annot), Item_t (t, rest, _)) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed
        ctxt
        loc
        Cons_some
        (Item_t (Option_t (t, ty_name, has_big_map t), rest, annot))
  | (Prim (loc, I_NONE, [t], annot), stack) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy t
      >>=? fun (Ex_ty t, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed
        ctxt
        loc
        (Cons_none t)
        (Item_t (Option_t (t, ty_name, has_big_map t), stack, annot))
  | ( Prim (loc, I_IF_NONE, [bt; bf], annot),
      (Item_t (Option_t (t, _, _), rest, option_annot) as bef) ) ->
      check_kind [Seq_kind] bt
      >>=? fun () ->
      check_kind [Seq_kind] bf
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let annot = gen_access_annot option_annot default_some_annot in
      parse_instr ?type_logger tc_context ctxt ~legacy bt rest
      >>=? fun (btr, ctxt) ->
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        bf
        (Item_t (t, rest, annot))
      >>=? fun (bfr, ctxt) ->
      let branch ibt ibf =
        {loc; instr = If_none (ibt, ibf); bef; aft = ibt.aft}
      in
      merge_branches ~legacy ctxt loc btr bfr {branch}
      >>=? fun (judgement, ctxt) -> return ctxt judgement
  (* pairs *)
  | ( Prim (loc, I_PAIR, [], annot),
      Item_t (a, Item_t (b, rest, snd_annot), fst_annot) ) ->
      parse_constr_annot
        loc
        annot
        ~if_special_first:(var_to_field_annot fst_annot)
        ~if_special_second:(var_to_field_annot snd_annot)
      >>=? fun (annot, ty_name, l_field, r_field) ->
      typed
        ctxt
        loc
        Cons_pair
        (Item_t
           ( Pair_t
               ( (a, l_field, fst_annot),
                 (b, r_field, snd_annot),
                 ty_name,
                 has_big_map a || has_big_map b ),
             rest,
             annot ))
  | ( Prim (loc, I_CAR, [], annot),
      Item_t
        (Pair_t ((a, expected_field_annot, a_annot), _, _, _), rest, pair_annot)
    ) ->
      parse_destr_annot
        loc
        annot
        ~pair_annot
        ~value_annot:a_annot
        ~field_name:expected_field_annot
        ~default_accessor:default_car_annot
      >>=? fun (annot, field_annot) ->
      Lwt.return @@ check_correct_field field_annot expected_field_annot
      >>=? fun () -> typed ctxt loc Car (Item_t (a, rest, annot))
  | ( Prim (loc, I_CDR, [], annot),
      Item_t
        (Pair_t (_, (b, expected_field_annot, b_annot), _, _), rest, pair_annot)
    ) ->
      parse_destr_annot
        loc
        annot
        ~pair_annot
        ~value_annot:b_annot
        ~field_name:expected_field_annot
        ~default_accessor:default_cdr_annot
      >>=? fun (annot, field_annot) ->
      Lwt.return @@ check_correct_field field_annot expected_field_annot
      >>=? fun () -> typed ctxt loc Cdr (Item_t (b, rest, annot))
  (* unions *)
  | (Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest, stack_annot)) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy tr
      >>=? fun (Ex_ty tr, ctxt) ->
      parse_constr_annot
        loc
        annot
        ~if_special_first:(var_to_field_annot stack_annot)
      >>=? fun (annot, tname, l_field, r_field) ->
      typed
        ctxt
        loc
        Left
        (Item_t
           ( Union_t
               ( (tl, l_field),
                 (tr, r_field),
                 tname,
                 has_big_map tl || has_big_map tr ),
             rest,
             annot ))
  | (Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest, stack_annot)) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy tl
      >>=? fun (Ex_ty tl, ctxt) ->
      parse_constr_annot
        loc
        annot
        ~if_special_second:(var_to_field_annot stack_annot)
      >>=? fun (annot, tname, l_field, r_field) ->
      typed
        ctxt
        loc
        Right
        (Item_t
           ( Union_t
               ( (tl, l_field),
                 (tr, r_field),
                 tname,
                 has_big_map tl || has_big_map tr ),
             rest,
             annot ))
  | ( Prim (loc, I_IF_LEFT, [bt; bf], annot),
      ( Item_t (Union_t ((tl, l_field), (tr, r_field), _, _), rest, union_annot)
      as bef ) ) ->
      check_kind [Seq_kind] bt
      >>=? fun () ->
      check_kind [Seq_kind] bf
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let left_annot =
        gen_access_annot union_annot l_field ~default:default_left_annot
      in
      let right_annot =
        gen_access_annot union_annot r_field ~default:default_right_annot
      in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        bt
        (Item_t (tl, rest, left_annot))
      >>=? fun (btr, ctxt) ->
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        bf
        (Item_t (tr, rest, right_annot))
      >>=? fun (bfr, ctxt) ->
      let branch ibt ibf =
        {loc; instr = If_left (ibt, ibf); bef; aft = ibt.aft}
      in
      merge_branches ~legacy ctxt loc btr bfr {branch}
      >>=? fun (judgement, ctxt) -> return ctxt judgement
  (* lists *)
  | (Prim (loc, I_NIL, [t], annot), stack) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy t
      >>=? fun (Ex_ty t, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed
        ctxt
        loc
        Nil
        (Item_t (List_t (t, ty_name, has_big_map t), stack, annot))
  | ( Prim (loc, I_CONS, [], annot),
      Item_t (tv, Item_t (List_t (t, ty_name, has_big_map), rest, _), _) ) ->
      check_item_ty ctxt tv t loc I_CONS 1 2
      >>=? fun (Eq, t, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Cons_list
        (Item_t (List_t (t, ty_name, has_big_map), rest, annot))
  | ( Prim (loc, I_IF_CONS, [bt; bf], annot),
      (Item_t (List_t (t, ty_name, has_big_map), rest, list_annot) as bef) ) ->
      check_kind [Seq_kind] bt
      >>=? fun () ->
      check_kind [Seq_kind] bf
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let hd_annot = gen_access_annot list_annot default_hd_annot in
      let tl_annot = gen_access_annot list_annot default_tl_annot in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        bt
        (Item_t
           ( t,
             Item_t (List_t (t, ty_name, has_big_map), rest, tl_annot),
             hd_annot ))
      >>=? fun (btr, ctxt) ->
      parse_instr ?type_logger tc_context ctxt ~legacy bf rest
      >>=? fun (bfr, ctxt) ->
      let branch ibt ibf =
        {loc; instr = If_cons (ibt, ibf); bef; aft = ibt.aft}
      in
      merge_branches ~legacy ctxt loc btr bfr {branch}
      >>=? fun (judgement, ctxt) -> return ctxt judgement
  | (Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest, _)) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, tname) ->
      typed ctxt loc List_size (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_MAP, [body], annot),
      Item_t (List_t (elt, _, _), starting_rest, list_annot) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      parse_var_type_annot loc annot
      >>=? fun (ret_annot, list_ty_name) ->
      let elt_annot = gen_access_annot list_annot default_elt_annot in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t (elt, starting_rest, elt_annot))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft = Item_t (ret, rest, _); _} as ibody) ->
          let invalid_map_body () =
            serialize_stack_for_error ctxt ibody.aft
            >>|? fun (aft, _ctxt) -> Invalid_map_body (loc, aft)
          in
          trace_eval
            invalid_map_body
            ( Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest
            >>=? fun (rest, ctxt) ->
            typed
              ctxt
              loc
              (List_map ibody)
              (Item_t
                 (List_t (ret, list_ty_name, has_big_map ret), rest, ret_annot))
            )
      | Typed {aft; _} ->
          serialize_stack_for_error ctxt aft
          >>=? fun (aft, _ctxt) -> fail (Invalid_map_body (loc, aft))
      | Failed _ ->
          fail (Invalid_map_block_fail loc) )
  | ( Prim (loc, I_ITER, [body], annot),
      Item_t (List_t (elt, _, _), rest, list_annot) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let elt_annot = gen_access_annot list_annot default_elt_annot in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t (elt, rest, elt_annot))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft; _} as ibody) ->
          let invalid_iter_body () =
            serialize_stack_for_error ctxt ibody.aft
            >>=? fun (aft, ctxt) ->
            serialize_stack_for_error ctxt rest
            >>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft)
          in
          trace_eval
            invalid_iter_body
            ( Lwt.return @@ stack_ty_eq ctxt 1 aft rest
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest
            >>=? fun (rest, ctxt) -> typed ctxt loc (List_iter ibody) rest )
      | Failed {descr} ->
          typed ctxt loc (List_iter (descr rest)) rest )
  (* sets *)
  | (Prim (loc, I_EMPTY_SET, [t], annot), rest) ->
      Lwt.return @@ parse_comparable_ty ctxt t
      >>=? fun (Ex_comparable_ty t, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, tname) ->
      typed ctxt loc (Empty_set t) (Item_t (Set_t (t, tname), rest, annot))
  | ( Prim (loc, I_ITER, [body], annot),
      Item_t (Set_t (comp_elt, _), rest, set_annot) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let elt_annot = gen_access_annot set_annot default_elt_annot in
      let elt = ty_of_comparable_ty comp_elt in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t (elt, rest, elt_annot))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft; _} as ibody) ->
          let invalid_iter_body () =
            serialize_stack_for_error ctxt ibody.aft
            >>=? fun (aft, ctxt) ->
            serialize_stack_for_error ctxt rest
            >>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft)
          in
          trace_eval
            invalid_iter_body
            ( Lwt.return @@ stack_ty_eq ctxt 1 aft rest
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest
            >>=? fun (rest, ctxt) -> typed ctxt loc (Set_iter ibody) rest )
      | Failed {descr} ->
          typed ctxt loc (Set_iter (descr rest)) rest )
  | ( Prim (loc, I_MEM, [], annot),
      Item_t (v, Item_t (Set_t (elt, _), rest, _), _) ) ->
      let elt = ty_of_comparable_ty elt in
      parse_var_type_annot loc annot
      >>=? fun (annot, tname) ->
      check_item_ty ctxt elt v loc I_MEM 1 2
      >>=? fun (Eq, _, ctxt) ->
      typed ctxt loc Set_mem (Item_t (Bool_t tname, rest, annot))
  | ( Prim (loc, I_UPDATE, [], annot),
      Item_t
        ( v,
          Item_t (Bool_t _, Item_t (Set_t (elt, tname), rest, set_annot), _),
          _ ) ) -> (
    match comparable_ty_of_ty v with
    | None ->
        unparse_ty ctxt v
        >>=? fun (v, _ctxt) ->
        fail (Comparable_type_expected (loc, Micheline.strip_locations v))
    | Some v ->
        parse_var_annot loc annot ~default:set_annot
        >>=? fun annot ->
        check_item_comparable_ty elt v loc I_UPDATE 1 3
        >>=? fun (Eq, elt) ->
        typed ctxt loc Set_update (Item_t (Set_t (elt, tname), rest, annot)) )
  | (Prim (loc, I_SIZE, [], annot), Item_t (Set_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Set_size (Item_t (Nat_t None, rest, annot))
  (* maps *)
  | (Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack) ->
      Lwt.return @@ parse_comparable_ty ctxt tk
      >>=? fun (Ex_comparable_ty tk, ctxt) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy tv
      >>=? fun (Ex_ty tv, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed
        ctxt
        loc
        (Empty_map (tk, tv))
        (Item_t (Map_t (tk, tv, ty_name, has_big_map tv), stack, annot))
  | ( Prim (loc, I_MAP, [body], annot),
      Item_t (Map_t (ck, elt, _, _), starting_rest, _map_annot) ) -> (
      let k = ty_of_comparable_ty ck in
      check_kind [Seq_kind] body
      >>=? fun () ->
      parse_var_type_annot loc annot
      >>=? fun (ret_annot, ty_name) ->
      let k_name = field_to_var_annot default_key_annot in
      let e_name = field_to_var_annot default_elt_annot in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t
           ( Pair_t
               ((k, None, k_name), (elt, None, e_name), None, has_big_map elt),
             starting_rest,
             None ))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft = Item_t (ret, rest, _); _} as ibody) ->
          let invalid_map_body () =
            serialize_stack_for_error ctxt ibody.aft
            >>|? fun (aft, _ctxt) -> Invalid_map_body (loc, aft)
          in
          trace_eval
            invalid_map_body
            ( Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest
            >>=? fun (rest, ctxt) ->
            typed
              ctxt
              loc
              (Map_map ibody)
              (Item_t
                 (Map_t (ck, ret, ty_name, has_big_map ret), rest, ret_annot))
            )
      | Typed {aft; _} ->
          serialize_stack_for_error ctxt aft
          >>=? fun (aft, _ctxt) -> fail (Invalid_map_body (loc, aft))
      | Failed _ ->
          fail (Invalid_map_block_fail loc) )
  | ( Prim (loc, I_ITER, [body], annot),
      Item_t (Map_t (comp_elt, element_ty, _, _), rest, _map_annot) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let k_name = field_to_var_annot default_key_annot in
      let e_name = field_to_var_annot default_elt_annot in
      let key = ty_of_comparable_ty comp_elt in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t
           ( Pair_t
               ( (key, None, k_name),
                 (element_ty, None, e_name),
                 None,
                 has_big_map element_ty ),
             rest,
             None ))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft; _} as ibody) ->
          let invalid_iter_body () =
            serialize_stack_for_error ctxt ibody.aft
            >>=? fun (aft, ctxt) ->
            serialize_stack_for_error ctxt rest
            >>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft)
          in
          trace_eval
            invalid_iter_body
            ( Lwt.return @@ stack_ty_eq ctxt 1 aft rest
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest
            >>=? fun (rest, ctxt) -> typed ctxt loc (Map_iter ibody) rest )
      | Failed {descr} ->
          typed ctxt loc (Map_iter (descr rest)) rest )
  | ( Prim (loc, I_MEM, [], annot),
      Item_t (vk, Item_t (Map_t (ck, _, _, _), rest, _), _) ) ->
      let k = ty_of_comparable_ty ck in
      check_item_ty ctxt vk k loc I_MEM 1 2
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Map_mem (Item_t (Bool_t None, rest, annot))
  | ( Prim (loc, I_GET, [], annot),
      Item_t (vk, Item_t (Map_t (ck, elt, _, has_big_map), rest, _), _) ) ->
      let k = ty_of_comparable_ty ck in
      check_item_ty ctxt vk k loc I_GET 1 2
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Map_get
        (Item_t (Option_t (elt, None, has_big_map), rest, annot))
  | ( Prim (loc, I_UPDATE, [], annot),
      Item_t
        ( vk,
          Item_t
            ( Option_t (vv, _, _),
              Item_t (Map_t (ck, v, map_name, has_big_map), rest, map_annot),
              _ ),
          _ ) ) ->
      let k = ty_of_comparable_ty ck in
      check_item_ty ctxt vk k loc I_UPDATE 1 3
      >>=? fun (Eq, _, ctxt) ->
      check_item_ty ctxt vv v loc I_UPDATE 2 3
      >>=? fun (Eq, v, ctxt) ->
      parse_var_annot loc annot ~default:map_annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Map_update
        (Item_t (Map_t (ck, v, map_name, has_big_map), rest, annot))
  | (Prim (loc, I_SIZE, [], annot), Item_t (Map_t (_, _, _, _), rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Map_size (Item_t (Nat_t None, rest, annot))
  (* big_map *)
  | (Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack) ->
      Lwt.return @@ parse_comparable_ty ctxt tk
      >>=? fun (Ex_comparable_ty tk, ctxt) ->
      Lwt.return @@ parse_packable_ty ctxt ~legacy tv
      >>=? fun (Ex_ty tv, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed
        ctxt
        loc
        (Empty_big_map (tk, tv))
        (Item_t (Big_map_t (tk, tv, ty_name), stack, annot))
  | ( Prim (loc, I_MEM, [], annot),
      Item_t (set_key, Item_t (Big_map_t (map_key, _, _), rest, _), _) ) ->
      let k = ty_of_comparable_ty map_key in
      check_item_ty ctxt set_key k loc I_MEM 1 2
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Big_map_mem (Item_t (Bool_t None, rest, annot))
  | ( Prim (loc, I_GET, [], annot),
      Item_t (vk, Item_t (Big_map_t (ck, elt, _), rest, _), _) ) ->
      let k = ty_of_comparable_ty ck in
      check_item_ty ctxt vk k loc I_GET 1 2
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Big_map_get
        (Item_t (Option_t (elt, None, has_big_map elt), rest, annot))
  | ( Prim (loc, I_UPDATE, [], annot),
      Item_t
        ( set_key,
          Item_t
            ( Option_t (set_value, _, _),
              Item_t (Big_map_t (map_key, map_value, map_name), rest, map_annot),
              _ ),
          _ ) ) ->
      let k = ty_of_comparable_ty map_key in
      check_item_ty ctxt set_key k loc I_UPDATE 1 3
      >>=? fun (Eq, _, ctxt) ->
      check_item_ty ctxt set_value map_value loc I_UPDATE 2 3
      >>=? fun (Eq, map_value, ctxt) ->
      parse_var_annot loc annot ~default:map_annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Big_map_update
        (Item_t (Big_map_t (map_key, map_value, map_name), rest, annot))
  (* control *)
  | (Seq (loc, []), stack) ->
      typed ctxt loc Nop stack
  | (Seq (loc, [single]), stack) -> (
      parse_instr ?type_logger tc_context ctxt ~legacy single stack
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft; _} as instr) ->
          let nop = {bef = aft; loc; aft; instr = Nop} in
          typed ctxt loc (Seq (instr, nop)) aft
      | Failed {descr; _} ->
          let descr aft =
            let nop = {bef = aft; loc; aft; instr = Nop} in
            let descr = descr aft in
            {descr with instr = Seq (descr, nop)}
          in
          return ctxt (Failed {descr}) )
  | (Seq (loc, hd :: tl), stack) -> (
      parse_instr ?type_logger tc_context ctxt ~legacy hd stack
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Failed _ ->
          fail (Fail_not_in_tail_position (Micheline.location hd))
      | Typed ({aft = middle; _} as ihd) -> (
          parse_instr
            ?type_logger
            tc_context
            ctxt
            ~legacy
            (Seq (-1, tl))
            middle
          >>=? fun (judgement, ctxt) ->
          match judgement with
          | Failed {descr} ->
              let descr ret =
                {loc; instr = Seq (ihd, descr ret); bef = stack; aft = ret}
              in
              return ctxt (Failed {descr})
          | Typed itl ->
              typed ctxt loc (Seq (ihd, itl)) itl.aft ) )
  | (Prim (loc, I_IF, [bt; bf], annot), (Item_t (Bool_t _, rest, _) as bef)) ->
      check_kind [Seq_kind] bt
      >>=? fun () ->
      check_kind [Seq_kind] bf
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      parse_instr ?type_logger tc_context ctxt ~legacy bt rest
      >>=? fun (btr, ctxt) ->
      parse_instr ?type_logger tc_context ctxt ~legacy bf rest
      >>=? fun (bfr, ctxt) ->
      let branch ibt ibf = {loc; instr = If (ibt, ibf); bef; aft = ibt.aft} in
      merge_branches ~legacy ctxt loc btr bfr {branch}
      >>=? fun (judgement, ctxt) -> return ctxt judgement
  | ( Prim (loc, I_LOOP, [body], annot),
      (Item_t (Bool_t _, rest, _stack_annot) as stack) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      parse_instr ?type_logger tc_context ctxt ~legacy body rest
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ibody ->
          let unmatched_branches () =
            serialize_stack_for_error ctxt ibody.aft
            >>=? fun (aft, ctxt) ->
            serialize_stack_for_error ctxt stack
            >>|? fun (stack, _ctxt) -> Unmatched_branches (loc, aft, stack)
          in
          trace_eval
            unmatched_branches
            ( Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack
            >>=? fun (_stack, ctxt) -> typed ctxt loc (Loop ibody) rest )
      | Failed {descr} ->
          let ibody = descr stack in
          typed ctxt loc (Loop ibody) rest )
  | ( Prim (loc, I_LOOP_LEFT, [body], annot),
      ( Item_t (Union_t ((tl, l_field), (tr, _), _, _), rest, union_annot) as
      stack ) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      parse_var_annot loc annot
      >>=? fun annot ->
      let l_annot =
        gen_access_annot union_annot l_field ~default:default_left_annot
      in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t (tl, rest, l_annot))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ibody ->
          let unmatched_branches () =
            serialize_stack_for_error ctxt ibody.aft
            >>=? fun (aft, ctxt) ->
            serialize_stack_for_error ctxt stack
            >>|? fun (stack, _ctxt) -> Unmatched_branches (loc, aft, stack)
          in
          trace_eval
            unmatched_branches
            ( Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack
            >>=? fun (_stack, ctxt) ->
            typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)) )
      | Failed {descr} ->
          let ibody = descr stack in
          typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)) )
  | (Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy arg
      >>=? fun (Ex_ty arg, ctxt) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy ret
      >>=? fun (Ex_ty ret, ctxt) ->
      check_kind [Seq_kind] code
      >>=? fun () ->
      parse_var_annot loc annot
      >>=? fun annot ->
      parse_returning
        Lambda
        ?type_logger
        ctxt
        ~legacy
        (arg, default_arg_annot)
        ret
        code
      >>=? fun (lambda, ctxt) ->
      typed
        ctxt
        loc
        (Lambda lambda)
        (Item_t (Lambda_t (arg, ret, None), stack, annot))
  | ( Prim (loc, I_EXEC, [], annot),
      Item_t (arg, Item_t (Lambda_t (param, ret, _), rest, _), _) ) ->
      check_item_ty ctxt arg param loc I_EXEC 1 2
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Exec (Item_t (ret, rest, annot))
  | ( Prim (loc, I_APPLY, [], annot),
      Item_t
        ( capture,
          Item_t
            ( Lambda_t
                ( Pair_t ((capture_ty, _, _), (arg_ty, _, _), lam_annot, _),
                  ret,
                  _ ),
              rest,
              _ ),
          _ ) ) ->
      Lwt.return @@ check_packable ~legacy:false loc capture_ty
      >>=? fun () ->
      check_item_ty ctxt capture capture_ty loc I_APPLY 1 2
      >>=? fun (Eq, capture_ty, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        (Apply capture_ty)
        (Item_t (Lambda_t (arg_ty, ret, lam_annot), rest, annot))
  | (Prim (loc, I_DIP, [code], annot), Item_t (v, rest, stack_annot)) -> (
      fail_unexpected_annot loc annot
      >>=? fun () ->
      check_kind [Seq_kind] code
      >>=? fun () ->
      parse_instr
        ?type_logger
        (add_dip v stack_annot tc_context)
        ctxt
        ~legacy
        code
        rest
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed descr ->
          typed ctxt loc (Dip descr) (Item_t (v, descr.aft, stack_annot))
      | Failed _ ->
          fail (Fail_not_in_tail_position loc) )
  | (Prim (loc, I_DIP, [n; code], result_annot), stack)
    when match parse_int32 n with Ok _ -> true | Error _ -> false ->
      let rec make_proof_argument :
          type tstk.
          int
          (* -> (fbef stack_ty -> (fbef judgement * context) tzresult Lwt.t) *) ->
          tc_context ->
          tstk stack_ty ->
          tstk dipn_proof_argument tzresult Lwt.t =
       fun n inner_tc_context stk ->
        match (Compare.Int.(n = 0), stk) with
        | (true, rest) -> (
            parse_instr ?type_logger inner_tc_context ctxt ~legacy code rest
            >>=? fun (judgement, ctxt) ->
            match judgement with
            | Typed descr ->
                outer_return
                @@ Dipn_proof_argument (Rest, (ctxt, descr), descr.aft)
            | Failed _ ->
                fail (Fail_not_in_tail_position loc) )
        | (false, Item_t (v, rest, annot)) ->
            make_proof_argument (n - 1) (add_dip v annot tc_context) rest
            >>=? fun (Dipn_proof_argument (n', descr, aft')) ->
            outer_return
            @@ Dipn_proof_argument (Prefix n', descr, Item_t (v, aft', annot))
        | (_, _) ->
            serialize_stack_for_error ctxt stack
            >>=? fun (whole_stack, _ctxt) ->
            fail (Bad_stack (loc, I_DIP, 1, whole_stack))
      in
      Lwt.return (parse_int32 n)
      >>=? fun n ->
      fail_unexpected_annot loc result_annot
      >>=? fun () ->
      make_proof_argument n tc_context stack
      >>=? fun (Dipn_proof_argument (n', (new_ctxt, descr), aft)) ->
      (* TODO: which context should be used in the next line? new_ctxt or the old ctxt? *)
      typed new_ctxt loc (Dipn (n, n', descr)) aft
  | (Prim (loc, I_DIP, (([] | _ :: _ :: _ :: _) as l), _), _) ->
      (* Technically, the arities 1 and 2 are allowed but the error only mentions 2.
           However, DIP {code} is equivalent to DIP 1 {code} so hinting at an arity of 2 makes sense. *)
      fail (Invalid_arity (loc, I_DIP, 2, List.length l))
  | (Prim (loc, I_FAILWITH, [], annot), Item_t (v, _rest, _)) ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let descr aft = {loc; instr = Failwith v; bef = stack_ty; aft} in
      log_stack ctxt loc stack_ty Empty_t
      >>=? fun () -> return ctxt (Failed {descr})
  (* timestamp operations *)
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Add_timestamp_to_seconds
        (Item_t (Timestamp_t tname, rest, annot))
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Int_t _, Item_t (Timestamp_t tname, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Add_seconds_to_timestamp
        (Item_t (Timestamp_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Sub_timestamp_seconds
        (Item_t (Timestamp_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Timestamp_t tn1, Item_t (Timestamp_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Diff_timestamps (Item_t (Int_t tname, rest, annot))
  (* string operations *)
  | ( Prim (loc, I_CONCAT, [], annot),
      Item_t (String_t tn1, Item_t (String_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Concat_string_pair (Item_t (String_t tname, rest, annot))
  | ( Prim (loc, I_CONCAT, [], annot),
      Item_t (List_t (String_t tname, _, _), rest, list_annot) ) ->
      parse_var_annot ~default:list_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Concat_string (Item_t (String_t tname, rest, annot))
  | ( Prim (loc, I_SLICE, [], annot),
      Item_t
        ( Nat_t _,
          Item_t (Nat_t _, Item_t (String_t tname, rest, string_annot), _),
          _ ) ) ->
      parse_var_annot
        ~default:(gen_access_annot string_annot default_slice_annot)
        loc
        annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Slice_string
        (Item_t (Option_t (String_t tname, None, false), rest, annot))
  | (Prim (loc, I_SIZE, [], annot), Item_t (String_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc String_size (Item_t (Nat_t None, rest, annot))
  (* bytes operations *)
  | ( Prim (loc, I_CONCAT, [], annot),
      Item_t (Bytes_t tn1, Item_t (Bytes_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Concat_bytes_pair (Item_t (Bytes_t tname, rest, annot))
  | ( Prim (loc, I_CONCAT, [], annot),
      Item_t (List_t (Bytes_t tname, _, _), rest, list_annot) ) ->
      parse_var_annot ~default:list_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Concat_bytes (Item_t (Bytes_t tname, rest, annot))
  | ( Prim (loc, I_SLICE, [], annot),
      Item_t
        ( Nat_t _,
          Item_t (Nat_t _, Item_t (Bytes_t tname, rest, bytes_annot), _),
          _ ) ) ->
      parse_var_annot
        ~default:(gen_access_annot bytes_annot default_slice_annot)
        loc
        annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Slice_bytes
        (Item_t (Option_t (Bytes_t tname, None, false), rest, annot))
  | (Prim (loc, I_SIZE, [], annot), Item_t (Bytes_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Bytes_size (Item_t (Nat_t None, rest, annot))
  (* currency operations *)
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Add_tez (Item_t (Mutez_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Sub_tez (Item_t (Mutez_t tname, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      (* no type name check *)
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Mul_teznat (Item_t (Mutez_t tname, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Nat_t _, Item_t (Mutez_t tname, rest, _), _) ) ->
      (* no type name check *)
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Mul_nattez (Item_t (Mutez_t tname, rest, annot))
  (* boolean operations *)
  | ( Prim (loc, I_OR, [], annot),
      Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname -> typed ctxt loc Or (Item_t (Bool_t tname, rest, annot))
  | ( Prim (loc, I_AND, [], annot),
      Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname -> typed ctxt loc And (Item_t (Bool_t tname, rest, annot))
  | ( Prim (loc, I_XOR, [], annot),
      Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname -> typed ctxt loc Xor (Item_t (Bool_t tname, rest, annot))
  | (Prim (loc, I_NOT, [], annot), Item_t (Bool_t tname, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Not (Item_t (Bool_t tname, rest, annot))
  (* integer operations *)
  | (Prim (loc, I_ABS, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Abs_int (Item_t (Nat_t None, rest, annot))
  | (Prim (loc, I_ISNAT, [], annot), Item_t (Int_t _, rest, int_annot)) ->
      parse_var_annot loc annot ~default:int_annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Is_nat
        (Item_t (Option_t (Nat_t None, None, false), rest, annot))
  | (Prim (loc, I_INT, [], annot), Item_t (Nat_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Int_nat (Item_t (Int_t None, rest, annot))
  | (Prim (loc, I_NEG, [], annot), Item_t (Int_t tname, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Neg_int (Item_t (Int_t tname, rest, annot))
  | (Prim (loc, I_NEG, [], annot), Item_t (Nat_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Neg_nat (Item_t (Int_t None, rest, annot))
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Add_intint (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Add_intnat (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Add_natint (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Add_natnat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun _tname ->
      typed ctxt loc Sub_int (Item_t (Int_t None, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Mul_intint (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Mul_intnat (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Mul_natint (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Mul_natnat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Ediv_teznat
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Mutez_t tname, None, None),
                     (Mutez_t tname, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed
        ctxt
        loc
        Ediv_tez
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Nat_t None, None, None),
                     (Mutez_t tname, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed
        ctxt
        loc
        Ediv_intint
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Int_t tname, None, None),
                     (Nat_t None, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Ediv_intnat
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Int_t tname, None, None),
                     (Nat_t None, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Nat_t tname, Item_t (Int_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Ediv_natint
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Int_t None, None, None),
                     (Nat_t tname, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed
        ctxt
        loc
        Ediv_natnat
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Nat_t tname, None, None),
                     (Nat_t tname, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_LSL, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Lsl_nat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_LSR, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Lsr_nat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_OR, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Or_nat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_AND, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc And_nat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_AND, [], annot),
      Item_t (Int_t _, Item_t (Nat_t tname, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc And_int_nat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_XOR, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Xor_nat (Item_t (Nat_t tname, rest, annot))
  | (Prim (loc, I_NOT, [], annot), Item_t (Int_t tname, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Not_int (Item_t (Int_t tname, rest, annot))
  | (Prim (loc, I_NOT, [], annot), Item_t (Nat_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Not_nat (Item_t (Int_t None, rest, annot))
  (* comparison *)
  | (Prim (loc, I_COMPARE, [], annot), Item_t (t1, Item_t (t2, rest, _), _))
    -> (
      parse_var_annot loc annot
      >>=? fun annot ->
      check_item_ty ctxt t1 t2 loc I_COMPARE 1 2
      >>=? fun (Eq, t, ctxt) ->
      match comparable_ty_of_ty t with
      | None ->
          Lwt.return (serialize_ty_for_error ctxt t)
          >>=? fun (t, _ctxt) -> fail (Comparable_type_expected (loc, t))
      | Some key ->
          typed ctxt loc (Compare key) (Item_t (Int_t None, rest, annot)) )
  (* comparators *)
  | (Prim (loc, I_EQ, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Eq (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_NEQ, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Neq (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_LT, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Lt (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_GT, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Gt (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_LE, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Le (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_GE, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Ge (Item_t (Bool_t None, rest, annot))
  (* annotations *)
  | (Prim (loc, I_CAST, [cast_t], annot), Item_t (t, stack, item_annot)) ->
      parse_var_annot loc annot ~default:item_annot
      >>=? fun annot ->
      Lwt.return @@ parse_any_ty ctxt ~legacy cast_t
      >>=? fun (Ex_ty cast_t, ctxt) ->
      Lwt.return @@ ty_eq ctxt cast_t t
      >>=? fun (Eq, ctxt) ->
      Lwt.return @@ merge_types ~legacy ctxt loc cast_t t
      >>=? fun (_, ctxt) -> typed ctxt loc Nop (Item_t (cast_t, stack, annot))
  | (Prim (loc, I_RENAME, [], annot), Item_t (t, stack, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      (* can erase annot *)
      typed ctxt loc Nop (Item_t (t, stack, annot))
  (* packing *)
  | (Prim (loc, I_PACK, [], annot), Item_t (t, rest, unpacked_annot)) ->
      Lwt.return
        (check_packable
           ~legacy:true
           (* allow to pack contracts for hash/signature checks *) loc
           t)
      >>=? fun () ->
      parse_var_annot
        loc
        annot
        ~default:(gen_access_annot unpacked_annot default_pack_annot)
      >>=? fun annot ->
      typed ctxt loc (Pack t) (Item_t (Bytes_t None, rest, annot))
  | (Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t _, rest, packed_annot))
    ->
      Lwt.return @@ parse_packable_ty ctxt ~legacy ty
      >>=? fun (Ex_ty t, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      let annot =
        default_annot
          annot
          ~default:(gen_access_annot packed_annot default_unpack_annot)
      in
      typed
        ctxt
        loc
        (Unpack t)
        (Item_t
           ( Option_t (t, ty_name, false (* cannot unpack big_maps *)),
             rest,
             annot ))
  (* protocol *)
  | ( Prim (loc, I_ADDRESS, [], annot),
      Item_t (Contract_t _, rest, contract_annot) ) ->
      parse_var_annot
        loc
        annot
        ~default:(gen_access_annot contract_annot default_addr_annot)
      >>=? fun annot ->
      typed ctxt loc Address (Item_t (Address_t None, rest, annot))
  | ( Prim (loc, I_CONTRACT, [ty], annot),
      Item_t (Address_t _, rest, addr_annot) ) ->
      Lwt.return @@ parse_parameter_ty ctxt ~legacy ty
      >>=? fun (Ex_ty t, ctxt) ->
      parse_entrypoint_annot
        loc
        annot
        ~default:(gen_access_annot addr_annot default_contract_annot)
      >>=? fun (annot, entrypoint) ->
      ( Lwt.return
      @@
      match entrypoint with
      | None ->
          Ok "default"
      | Some (`Field_annot "default") ->
          error (Unexpected_annotation loc)
      | Some (`Field_annot entrypoint) ->
          if Compare.Int.(String.length entrypoint > 31) then
            error (Entrypoint_name_too_long entrypoint)
          else Ok entrypoint )
      >>=? fun entrypoint ->
      typed
        ctxt
        loc
        (Contract (t, entrypoint))
        (Item_t (Option_t (Contract_t (t, None), None, false), rest, annot))
  | ( Prim (loc, I_TRANSFER_TOKENS, [], annot),
      Item_t (p, Item_t (Mutez_t _, Item_t (Contract_t (cp, _), rest, _), _), _)
    ) ->
      check_item_ty ctxt p cp loc I_TRANSFER_TOKENS 1 4
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Transfer_tokens (Item_t (Operation_t None, rest, annot))
  | ( Prim (loc, I_SET_DELEGATE, [], annot),
      Item_t (Option_t (Key_hash_t _, _, _), rest, _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Set_delegate (Item_t (Operation_t None, rest, annot))
  | ( Prim (loc, I_CREATE_ACCOUNT, [], annot),
      Item_t
        ( Key_hash_t _,
          Item_t
            ( Option_t (Key_hash_t _, _, _),
              Item_t (Bool_t _, Item_t (Mutez_t _, rest, _), _),
              _ ),
          _ ) ) ->
      if legacy then
        (* For existing contracts, this instruction is still allowed *)
        parse_two_var_annot loc annot
        >>=? fun (op_annot, addr_annot) ->
        typed
          ctxt
          loc
          Create_account
          (Item_t
             ( Operation_t None,
               Item_t (Address_t None, rest, addr_annot),
               op_annot ))
      else
        (* For new contracts this instruction is not allowed anymore *)
        fail (Deprecated_instruction I_CREATE_ACCOUNT)
  | (Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), Item_t (Key_hash_t _, rest, _))
    ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Implicit_account
        (Item_t (Contract_t (Unit_t None, None), rest, annot))
  | ( Prim (loc, I_CREATE_CONTRACT, [(Seq _ as code)], annot),
      Item_t
        ( Key_hash_t _,
          Item_t
            ( Option_t (Key_hash_t _, _, _),
              Item_t
                ( Bool_t _,
                  Item_t
                    ( Bool_t _,
                      Item_t (Mutez_t _, Item_t (ginit, rest, _), _),
                      _ ),
                  _ ),
              _ ),
          _ ) ) ->
      if legacy then
        (* For existing contracts, this instruction is still allowed *)
        parse_two_var_annot loc annot
        >>=? fun (op_annot, addr_annot) ->
        let cannonical_code = fst @@ Micheline.extract_locations code in
        Lwt.return @@ parse_toplevel ~legacy cannonical_code
        >>=? fun (arg_type, storage_type, code_field, root_name) ->
        trace
          (Ill_formed_type
             (Some "parameter", cannonical_code, location arg_type))
          (Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type)
        >>=? fun (Ex_ty arg_type, ctxt) ->
        ( if legacy then Error_monad.return ()
        else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
        >>=? fun () ->
        trace
          (Ill_formed_type
             (Some "storage", cannonical_code, location storage_type))
          (Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type)
        >>=? fun (Ex_ty storage_type, ctxt) ->
        let arg_annot =
          default_annot
            (type_to_var_annot (name_of_ty arg_type))
            ~default:default_param_annot
        in
        let storage_annot =
          default_annot
            (type_to_var_annot (name_of_ty storage_type))
            ~default:default_storage_annot
        in
        let arg_type_full =
          Pair_t
            ( (arg_type, None, arg_annot),
              (storage_type, None, storage_annot),
              None,
              has_big_map arg_type || has_big_map storage_type )
        in
        let ret_type_full =
          Pair_t
            ( (List_t (Operation_t None, None, false), None, None),
              (storage_type, None, None),
              None,
              has_big_map storage_type )
        in
        trace
          (Ill_typed_contract (cannonical_code, []))
          (parse_returning
             (Toplevel
                {
                  storage_type;
                  param_type = arg_type;
                  root_name;
                  legacy_create_contract_literal = true;
                })
             ctxt
             ~legacy
             ?type_logger
             (arg_type_full, None)
             ret_type_full
             code_field)
        >>=? fun ( ( Lam
                       ( { bef = Item_t (arg, Empty_t, _);
                           aft = Item_t (ret, Empty_t, _);
                           _ },
                         _ ) as lambda ),
                   ctxt ) ->
        Lwt.return @@ ty_eq ctxt arg arg_type_full
        >>=? fun (Eq, ctxt) ->
        Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full
        >>=? fun (_, ctxt) ->
        Lwt.return @@ ty_eq ctxt ret ret_type_full
        >>=? fun (Eq, ctxt) ->
        Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full
        >>=? fun (_, ctxt) ->
        Lwt.return @@ ty_eq ctxt storage_type ginit
        >>=? fun (Eq, ctxt) ->
        Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit
        >>=? fun (_, ctxt) ->
        typed
          ctxt
          loc
          (Create_contract (storage_type, arg_type, lambda, root_name))
          (Item_t
             ( Operation_t None,
               Item_t (Address_t None, rest, addr_annot),
               op_annot ))
      else
        (* For new contracts this instruction is not allowed anymore *)
        fail (Deprecated_instruction I_CREATE_CONTRACT)
  | ( Prim (loc, I_CREATE_CONTRACT, [(Seq _ as code)], annot),
      (* Removed the instruction's arguments manager, spendable and delegatable *)
    Item_t
      ( Option_t (Key_hash_t _, _, _),
        Item_t (Mutez_t _, Item_t (ginit, rest, _), _),
        _ ) ) ->
      parse_two_var_annot loc annot
      >>=? fun (op_annot, addr_annot) ->
      let cannonical_code = fst @@ Micheline.extract_locations code in
      Lwt.return @@ parse_toplevel ~legacy cannonical_code
      >>=? fun (arg_type, storage_type, code_field, root_name) ->
      trace
        (Ill_formed_type (Some "parameter", cannonical_code, location arg_type))
        (Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type)
      >>=? fun (Ex_ty arg_type, ctxt) ->
      ( if legacy then Error_monad.return ()
      else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
      >>=? fun () ->
      trace
        (Ill_formed_type
           (Some "storage", cannonical_code, location storage_type))
        (Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type)
      >>=? fun (Ex_ty storage_type, ctxt) ->
      let arg_annot =
        default_annot
          (type_to_var_annot (name_of_ty arg_type))
          ~default:default_param_annot
      in
      let storage_annot =
        default_annot
          (type_to_var_annot (name_of_ty storage_type))
          ~default:default_storage_annot
      in
      let arg_type_full =
        Pair_t
          ( (arg_type, None, arg_annot),
            (storage_type, None, storage_annot),
            None,
            has_big_map arg_type || has_big_map storage_type )
      in
      let ret_type_full =
        Pair_t
          ( (List_t (Operation_t None, None, false), None, None),
            (storage_type, None, None),
            None,
            has_big_map storage_type )
      in
      trace
        (Ill_typed_contract (cannonical_code, []))
        (parse_returning
           (Toplevel
              {
                storage_type;
                param_type = arg_type;
                root_name;
                legacy_create_contract_literal = false;
              })
           ctxt
           ~legacy
           ?type_logger
           (arg_type_full, None)
           ret_type_full
           code_field)
      >>=? fun ( ( Lam
                     ( { bef = Item_t (arg, Empty_t, _);
                         aft = Item_t (ret, Empty_t, _);
                         _ },
                       _ ) as lambda ),
                 ctxt ) ->
      Lwt.return @@ ty_eq ctxt arg arg_type_full
      >>=? fun (Eq, ctxt) ->
      Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full
      >>=? fun (_, ctxt) ->
      Lwt.return @@ ty_eq ctxt ret ret_type_full
      >>=? fun (Eq, ctxt) ->
      Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full
      >>=? fun (_, ctxt) ->
      Lwt.return @@ ty_eq ctxt storage_type ginit
      >>=? fun (Eq, ctxt) ->
      Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit
      >>=? fun (_, ctxt) ->
      typed
        ctxt
        loc
        (Create_contract_2 (storage_type, arg_type, lambda, root_name))
        (Item_t
           ( Operation_t None,
             Item_t (Address_t None, rest, addr_annot),
             op_annot ))
  | (Prim (loc, I_NOW, [], annot), stack) ->
      parse_var_annot loc annot ~default:default_now_annot
      >>=? fun annot ->
      typed ctxt loc Now (Item_t (Timestamp_t None, stack, annot))
  | (Prim (loc, I_AMOUNT, [], annot), stack) ->
      parse_var_annot loc annot ~default:default_amount_annot
      >>=? fun annot ->
      typed ctxt loc Amount (Item_t (Mutez_t None, stack, annot))
  | (Prim (loc, I_CHAIN_ID, [], annot), stack) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc ChainId (Item_t (Chain_id_t None, stack, annot))
  | (Prim (loc, I_BALANCE, [], annot), stack) ->
      parse_var_annot loc annot ~default:default_balance_annot
      >>=? fun annot ->
      typed ctxt loc Balance (Item_t (Mutez_t None, stack, annot))
  | (Prim (loc, I_HASH_KEY, [], annot), Item_t (Key_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Hash_key (Item_t (Key_hash_t None, rest, annot))
  | ( Prim (loc, I_CHECK_SIGNATURE, [], annot),
      Item_t
        (Key_t _, Item_t (Signature_t _, Item_t (Bytes_t _, rest, _), _), _) )
    ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Check_signature (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_BLAKE2B, [], annot), Item_t (Bytes_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Blake2b (Item_t (Bytes_t None, rest, annot))
  | (Prim (loc, I_SHA256, [], annot), Item_t (Bytes_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Sha256 (Item_t (Bytes_t None, rest, annot))
  | (Prim (loc, I_SHA512, [], annot), Item_t (Bytes_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Sha512 (Item_t (Bytes_t None, rest, annot))
  | (Prim (loc, I_STEPS_TO_QUOTA, [], annot), stack) ->
      if legacy then
        (* For existing contracts, this instruction is still allowed *)
        parse_var_annot loc annot ~default:default_steps_annot
        >>=? fun annot ->
        typed ctxt loc Steps_to_quota (Item_t (Nat_t None, stack, annot))
      else
        (* For new contracts this instruction is not allowed anymore *)
        fail (Deprecated_instruction I_STEPS_TO_QUOTA)
  | (Prim (loc, I_SOURCE, [], annot), stack) ->
      parse_var_annot loc annot ~default:default_source_annot
      >>=? fun annot ->
      typed ctxt loc Source (Item_t (Address_t None, stack, annot))
  | (Prim (loc, I_SENDER, [], annot), stack) ->
      parse_var_annot loc annot ~default:default_sender_annot
      >>=? fun annot ->
      typed ctxt loc Sender (Item_t (Address_t None, stack, annot))
  | (Prim (loc, I_SELF, [], annot), stack) ->
      parse_entrypoint_annot loc annot ~default:default_self_annot
      >>=? fun (annot, entrypoint) ->
      let entrypoint =
        Option.unopt_map
          ~f:(fun (`Field_annot annot) -> annot)
          ~default:"default"
          entrypoint
      in
      let rec get_toplevel_type :
          tc_context -> (bef judgement * context) tzresult Lwt.t = function
        | Lambda ->
            fail (Self_in_lambda loc)
        | Dip (_, prev) ->
            get_toplevel_type prev
        | Toplevel
            {param_type; root_name; legacy_create_contract_literal = false} ->
            Lwt.return (find_entrypoint param_type ~root_name entrypoint)
            >>=? fun (_, Ex_ty param_type) ->
            typed
              ctxt
              loc
              (Self (param_type, entrypoint))
              (Item_t (Contract_t (param_type, None), stack, annot))
        | Toplevel
            {param_type; root_name = _; legacy_create_contract_literal = true}
          ->
            typed
              ctxt
              loc
              (Self (param_type, "default"))
              (Item_t (Contract_t (param_type, None), stack, annot))
      in
      get_toplevel_type tc_context
  (* Primitive parsing errors *)
  | ( Prim
        ( loc,
          ( ( I_DUP
            | I_SWAP
            | I_SOME
            | I_UNIT
            | I_PAIR
            | I_CAR
            | I_CDR
            | I_CONS
            | I_CONCAT
            | I_SLICE
            | I_MEM
            | I_UPDATE
            | I_MAP
            | I_GET
            | I_EXEC
            | I_FAILWITH
            | I_SIZE
            | I_ADD
            | I_SUB
            | I_MUL
            | I_EDIV
            | I_OR
            | I_AND
            | I_XOR
            | I_NOT
            | I_ABS
            | I_NEG
            | I_LSL
            | I_LSR
            | I_COMPARE
            | I_EQ
            | I_NEQ
            | I_LT
            | I_GT
            | I_LE
            | I_GE
            | I_TRANSFER_TOKENS
            | I_CREATE_ACCOUNT
            | I_SET_DELEGATE
            | I_NOW
            | I_IMPLICIT_ACCOUNT
            | I_AMOUNT
            | I_BALANCE
            | I_CHECK_SIGNATURE
            | I_HASH_KEY
            | I_SOURCE
            | I_SENDER
            | I_BLAKE2B
            | I_SHA256
            | I_SHA512
            | I_STEPS_TO_QUOTA
            | I_ADDRESS ) as name ),
          (_ :: _ as l),
          _ ),
      _ ) ->
      fail (Invalid_arity (loc, name, 0, List.length l))
  | ( Prim
        ( loc,
          ( ( I_NONE
            | I_LEFT
            | I_RIGHT
            | I_NIL
            | I_MAP
            | I_ITER
            | I_EMPTY_SET
            | I_DIP
            | I_LOOP
            | I_LOOP_LEFT
            | I_CONTRACT ) as name ),
          (([] | _ :: _ :: _) as l),
          _ ),
      _ ) ->
      fail (Invalid_arity (loc, name, 1, List.length l))
  | ( Prim
        ( loc,
          ( (I_PUSH | I_IF_NONE | I_IF_LEFT | I_IF_CONS | I_EMPTY_MAP | I_IF)
          as name ),
          (([] | [_] | _ :: _ :: _ :: _) as l),
          _ ),
      _ ) ->
      fail (Invalid_arity (loc, name, 2, List.length l))
  | (Prim (loc, I_LAMBDA, (([] | [_] | _ :: _ :: _ :: _ :: _) as l), _), _) ->
      fail (Invalid_arity (loc, I_LAMBDA, 3, List.length l))
  (* Stack errors *)
  | ( Prim
        ( loc,
          ( ( I_ADD
            | I_SUB
            | I_MUL
            | I_EDIV
            | I_AND
            | I_OR
            | I_XOR
            | I_LSL
            | I_LSR ) as name ),
          [],
          _ ),
      Item_t (ta, Item_t (tb, _, _), _) ) ->
      Lwt.return @@ serialize_ty_for_error ctxt ta
      >>=? fun (ta, ctxt) ->
      Lwt.return @@ serialize_ty_for_error ctxt tb
      >>=? fun (tb, _ctxt) -> fail (Undefined_binop (loc, name, ta, tb))
  | ( Prim
        ( loc,
          ( ( I_NEG
            | I_ABS
            | I_NOT
            | I_CONCAT
            | I_SIZE
            | I_EQ
            | I_NEQ
            | I_LT
            | I_GT
            | I_LE
            | I_GE ) as name ),
          [],
          _ ),
      Item_t (t, _, _) ) ->
      Lwt.return @@ serialize_ty_for_error ctxt t
      >>=? fun (t, _ctxt) -> fail (Undefined_unop (loc, name, t))
  | (Prim (loc, ((I_UPDATE | I_SLICE) as name), [], _), stack) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 3, stack))
  | (Prim (loc, I_CREATE_CONTRACT, _, _), stack) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) ->
      fail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack))
  | (Prim (loc, I_CREATE_ACCOUNT, [], _), stack) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) ->
      fail (Bad_stack (loc, I_CREATE_ACCOUNT, 4, stack))
  | (Prim (loc, I_TRANSFER_TOKENS, [], _), stack) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) ->
      fail (Bad_stack (loc, I_TRANSFER_TOKENS, 4, stack))
  | ( Prim
        ( loc,
          ( ( I_DROP
            | I_DUP
            | I_CAR
            | I_CDR
            | I_SOME
            | I_BLAKE2B
            | I_SHA256
            | I_SHA512
            | I_DIP
            | I_IF_NONE
            | I_LEFT
            | I_RIGHT
            | I_IF_LEFT
            | I_IF
            | I_LOOP
            | I_IF_CONS
            | I_IMPLICIT_ACCOUNT
            | I_NEG
            | I_ABS
            | I_INT
            | I_NOT
            | I_HASH_KEY
            | I_EQ
            | I_NEQ
            | I_LT
            | I_GT
            | I_LE
            | I_GE ) as name ),
          _,
          _ ),
      stack ) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 1, stack))
  | ( Prim
        ( loc,
          ( ( I_SWAP
            | I_PAIR
            | I_CONS
            | I_GET
            | I_MEM
            | I_EXEC
            | I_CHECK_SIGNATURE
            | I_ADD
            | I_SUB
            | I_MUL
            | I_EDIV
            | I_AND
            | I_OR
            | I_XOR
            | I_LSL
            | I_LSR ) as name ),
          _,
          _ ),
      stack ) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 2, stack))
  (* Generic parsing errors *)
  | (expr, _) ->
      fail
      @@ unexpected
           expr
           [Seq_kind]
           Instr_namespace
           [ I_DROP;
             I_DUP;
             I_DIG;
             I_DUG;
             I_SWAP;
             I_SOME;
             I_UNIT;
             I_PAIR;
             I_CAR;
             I_CDR;
             I_CONS;
             I_MEM;
             I_UPDATE;
             I_MAP;
             I_ITER;
             I_GET;
             I_EXEC;
             I_FAILWITH;
             I_SIZE;
             I_CONCAT;
             I_ADD;
             I_SUB;
             I_MUL;
             I_EDIV;
             I_OR;
             I_AND;
             I_XOR;
             I_NOT;
             I_ABS;
             I_INT;
             I_NEG;
             I_LSL;
             I_LSR;
             I_COMPARE;
             I_EQ;
             I_NEQ;
             I_LT;
             I_GT;
             I_LE;
             I_GE;
             I_TRANSFER_TOKENS;
             I_CREATE_ACCOUNT;
             I_CREATE_CONTRACT;
             I_NOW;
             I_AMOUNT;
             I_BALANCE;
             I_IMPLICIT_ACCOUNT;
             I_CHECK_SIGNATURE;
             I_BLAKE2B;
             I_SHA256;
             I_SHA512;
             I_HASH_KEY;
             I_STEPS_TO_QUOTA;
             I_PUSH;
             I_NONE;
             I_LEFT;
             I_RIGHT;
             I_NIL;
             I_EMPTY_SET;
             I_DIP;
             I_LOOP;
             I_IF_NONE;
             I_IF_LEFT;
             I_IF_CONS;
             I_EMPTY_MAP;
             I_IF;
             I_SOURCE;
             I_SENDER;
             I_SELF;
             I_LAMBDA ]

and parse_contract :
    type arg.
    legacy:bool ->
    context ->
    Script.location ->
    arg ty ->
    Contract.t ->
    entrypoint:string ->
    (context * arg typed_contract) tzresult Lwt.t =
 fun ~legacy ctxt loc arg contract ~entrypoint ->
  Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists
  >>=? fun ctxt ->
  Contract.exists ctxt contract
  >>=? function
  | false ->
      fail (Invalid_contract (loc, contract))
  | true -> (
      Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script
      >>=? fun ctxt ->
      trace (Invalid_contract (loc, contract))
      @@ Contract.get_script_code ctxt contract
      >>=? fun (ctxt, code) ->
      match code with
      | None ->
          Lwt.return
            ( ty_eq ctxt arg (Unit_t None)
            >>? fun (Eq, ctxt) ->
            match entrypoint with
            | "default" ->
                let contract : arg typed_contract =
                  (arg, (contract, entrypoint))
                in
                ok (ctxt, contract)
            | entrypoint ->
                error (No_such_entrypoint entrypoint) )
      | Some code ->
          Script.force_decode ctxt code
          >>=? fun (code, ctxt) ->
          Lwt.return
            ( parse_toplevel ~legacy:true code
            >>? fun (arg_type, _, _, root_name) ->
            parse_parameter_ty ctxt ~legacy:true arg_type
            >>? fun (Ex_ty targ, ctxt) ->
            let return ctxt targ entrypoint =
              merge_types ~legacy ctxt loc targ arg
              >>? fun (arg, ctxt) ->
              let contract : arg typed_contract =
                (arg, (contract, entrypoint))
              in
              ok (ctxt, contract)
            in
            find_entrypoint_for_type
              ~full:targ
              ~expected:arg
              ~root_name
              entrypoint
              ctxt
            >>? fun (ctxt, entrypoint, targ) ->
            merge_types ~legacy ctxt loc targ arg
            >>? fun (targ, ctxt) -> return ctxt targ entrypoint ) )

(* Same as the one above, but does not fail when the contact is missing or
   if the expected type doesn't match the actual one. In that case None is
   returned and some overapproximation of the typechecking gas is consumed.
   This can still fail on gas exhaustion. *)
and parse_contract_for_script :
    type arg.
    legacy:bool ->
    context ->
    Script.location ->
    arg ty ->
    Contract.t ->
    entrypoint:string ->
    (context * arg typed_contract option) tzresult Lwt.t =
 fun ~legacy ctxt loc arg contract ~entrypoint ->
  Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists
  >>=? fun ctxt ->
  Contract.exists ctxt contract
  >>=? function
  | false ->
      return (ctxt, None)
  | true -> (
      Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script
      >>=? fun ctxt ->
      trace (Invalid_contract (loc, contract))
      @@ Contract.get_script_code ctxt contract
      >>=? fun (ctxt, code) ->
      match code with
      (* can only fail because of gas *)
      | None -> (
        match entrypoint with
        | "default" ->
            Lwt.return
              ( match ty_eq ctxt arg (Unit_t None) with
              | Ok (Eq, ctxt) ->
                  let contract : arg typed_contract =
                    (arg, (contract, entrypoint))
                  in
                  ok (ctxt, Some contract)
              | Error _ ->
                  Gas.consume ctxt Typecheck_costs.cycle
                  >>? fun ctxt -> ok (ctxt, None) )
        | _ ->
            return (ctxt, None) )
      | Some code ->
          Script.force_decode ctxt code
          >>=? fun (code, ctxt) ->
          (* can only fail because of gas *)
          Lwt.return
            ( match parse_toplevel ~legacy:true code with
            | Error _ ->
                error (Invalid_contract (loc, contract))
            | Ok (arg_type, _, _, root_name) -> (
              match parse_parameter_ty ctxt ~legacy:true arg_type with
              | Error _ ->
                  error (Invalid_contract (loc, contract))
              | Ok (Ex_ty targ, ctxt) -> (
                match
                  find_entrypoint_for_type
                    ~full:targ
                    ~expected:arg
                    ~root_name
                    entrypoint
                    ctxt
                  >>? fun (ctxt, entrypoint, targ) ->
                  merge_types ~legacy ctxt loc targ arg
                  >>? fun (targ, ctxt) ->
                  merge_types ~legacy ctxt loc targ arg
                  >>? fun (arg, ctxt) ->
                  let contract : arg typed_contract =
                    (arg, (contract, entrypoint))
                  in
                  ok (ctxt, Some contract)
                with
                | Ok res ->
                    ok res
                | Error _ ->
                    (* overapproximation by checking if targ = targ,
                                                       can only fail because of gas *)
                    ty_eq ctxt targ targ
                    >>? fun (Eq, ctxt) ->
                    merge_types ~legacy ctxt loc targ targ
                    >>? fun (_, ctxt) -> ok (ctxt, None) ) ) ) )

and parse_toplevel :
    legacy:bool ->
    Script.expr ->
    (Script.node * Script.node * Script.node * string option) tzresult =
 fun ~legacy toplevel ->
  record_trace (Ill_typed_contract (toplevel, []))
  @@
  match root toplevel with
  | Int (loc, _) ->
      error (Invalid_kind (loc, [Seq_kind], Int_kind))
  | String (loc, _) ->
      error (Invalid_kind (loc, [Seq_kind], String_kind))
  | Bytes (loc, _) ->
      error (Invalid_kind (loc, [Seq_kind], Bytes_kind))
  | Prim (loc, _, _, _) ->
      error (Invalid_kind (loc, [Seq_kind], Prim_kind))
  | Seq (_, fields) -> (
      let rec find_fields p s c fields =
        match fields with
        | [] ->
            ok (p, s, c)
        | Int (loc, _) :: _ ->
            error (Invalid_kind (loc, [Prim_kind], Int_kind))
        | String (loc, _) :: _ ->
            error (Invalid_kind (loc, [Prim_kind], String_kind))
        | Bytes (loc, _) :: _ ->
            error (Invalid_kind (loc, [Prim_kind], Bytes_kind))
        | Seq (loc, _) :: _ ->
            error (Invalid_kind (loc, [Prim_kind], Seq_kind))
        | Prim (loc, K_parameter, [arg], annot) :: rest -> (
          match p with
          | None ->
              find_fields (Some (arg, loc, annot)) s c rest
          | Some _ ->
              error (Duplicate_field (loc, K_parameter)) )
        | Prim (loc, K_storage, [arg], annot) :: rest -> (
          match s with
          | None ->
              find_fields p (Some (arg, loc, annot)) c rest
          | Some _ ->
              error (Duplicate_field (loc, K_storage)) )
        | Prim (loc, K_code, [arg], annot) :: rest -> (
          match c with
          | None ->
              find_fields p s (Some (arg, loc, annot)) rest
          | Some _ ->
              error (Duplicate_field (loc, K_code)) )
        | Prim (loc, ((K_parameter | K_storage | K_code) as name), args, _)
          :: _ ->
            error (Invalid_arity (loc, name, 1, List.length args))
        | Prim (loc, name, _, _) :: _ ->
            let allowed = [K_parameter; K_storage; K_code] in
            error (Invalid_primitive (loc, allowed, name))
      in
      find_fields None None None fields
      >>? function
      | (None, _, _) ->
          error (Missing_field K_parameter)
      | (Some _, None, _) ->
          error (Missing_field K_storage)
      | (Some _, Some _, None) ->
          error (Missing_field K_code)
      | (Some (p, ploc, pannot), Some (s, sloc, sannot), Some (c, cloc, carrot))
        ->
          let maybe_root_name =
            (* root name can be attached to either the parameter
                 primitive or the toplevel constructor *)
            Script_ir_annot.extract_field_annot p
            >>? fun (p, root_name) ->
            match root_name with
            | Some (`Field_annot root_name) ->
                ok (p, pannot, Some root_name)
            | None -> (
              match pannot with
              | [single]
                when Compare.Int.(String.length single > 0)
                     && Compare.Char.(single.[0] = '%') ->
                  ok
                    ( p,
                      [],
                      Some (String.sub single 1 (String.length single - 1)) )
              | _ ->
                  ok (p, pannot, None) )
          in
          if legacy then
            (* legacy semantics ignores spurious annotations *)
            let (p, root_name) =
              match maybe_root_name with
              | Ok (p, _, root_name) ->
                  (p, root_name)
              | Error _ ->
                  (p, None)
            in
            ok (p, s, c, root_name)
          else
            (* only one field annot is allowed to set the root entrypoint name *)
            maybe_root_name
            >>? fun (p, pannot, root_name) ->
            Script_ir_annot.error_unexpected_annot ploc pannot
            >>? fun () ->
            Script_ir_annot.error_unexpected_annot cloc carrot
            >>? fun () ->
            Script_ir_annot.error_unexpected_annot sloc sannot
            >>? fun () -> ok (p, s, c, root_name) )

let parse_script :
    ?type_logger:type_logger ->
    context ->
    legacy:bool ->
    Script.t ->
    (ex_script * context) tzresult Lwt.t =
 fun ?type_logger ctxt ~legacy {code; storage} ->
  Script.force_decode ctxt code
  >>=? fun (code, ctxt) ->
  Script.force_decode ctxt storage
  >>=? fun (storage, ctxt) ->
  Lwt.return @@ parse_toplevel ~legacy code
  >>=? fun (arg_type, storage_type, code_field, root_name) ->
  trace
    (Ill_formed_type (Some "parameter", code, location arg_type))
    (Lwt.return (parse_parameter_ty ctxt ~legacy arg_type))
  >>=? fun (Ex_ty arg_type, ctxt) ->
  ( if legacy then return ()
  else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
  >>=? fun () ->
  trace
    (Ill_formed_type (Some "storage", code, location storage_type))
    (Lwt.return (parse_storage_ty ctxt ~legacy storage_type))
  >>=? fun (Ex_ty storage_type, ctxt) ->
  let arg_annot =
    default_annot
      (type_to_var_annot (name_of_ty arg_type))
      ~default:default_param_annot
  in
  let storage_annot =
    default_annot
      (type_to_var_annot (name_of_ty storage_type))
      ~default:default_storage_annot
  in
  let arg_type_full =
    Pair_t
      ( (arg_type, None, arg_annot),
        (storage_type, None, storage_annot),
        None,
        has_big_map arg_type || has_big_map storage_type )
  in
  let ret_type_full =
    Pair_t
      ( (List_t (Operation_t None, None, false), None, None),
        (storage_type, None, None),
        None,
        has_big_map storage_type )
  in
  trace_eval
    (fun () ->
      Lwt.return @@ serialize_ty_for_error ctxt storage_type
      >>|? fun (storage_type, _ctxt) ->
      Ill_typed_data (None, storage, storage_type))
    (parse_data ?type_logger ctxt ~legacy storage_type (root storage))
  >>=? fun (storage, ctxt) ->
  trace
    (Ill_typed_contract (code, []))
    (parse_returning
       (Toplevel
          {
            storage_type;
            param_type = arg_type;
            root_name;
            legacy_create_contract_literal = false;
          })
       ctxt
       ~legacy
       ?type_logger
       (arg_type_full, None)
       ret_type_full
       code_field)
  >>=? fun (code, ctxt) ->
  return (Ex_script {code; arg_type; storage; storage_type; root_name}, ctxt)

let typecheck_code :
    context -> Script.expr -> (type_map * context) tzresult Lwt.t =
 fun ctxt code ->
  let legacy = false in
  Lwt.return @@ parse_toplevel ~legacy code
  >>=? fun (arg_type, storage_type, code_field, root_name) ->
  let type_map = ref [] in
  trace
    (Ill_formed_type (Some "parameter", code, location arg_type))
    (Lwt.return (parse_parameter_ty ctxt ~legacy arg_type))
  >>=? fun (Ex_ty arg_type, ctxt) ->
  ( if legacy then return ()
  else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
  >>=? fun () ->
  trace
    (Ill_formed_type (Some "storage", code, location storage_type))
    (Lwt.return (parse_storage_ty ctxt ~legacy storage_type))
  >>=? fun (Ex_ty storage_type, ctxt) ->
  let arg_annot =
    default_annot
      (type_to_var_annot (name_of_ty arg_type))
      ~default:default_param_annot
  in
  let storage_annot =
    default_annot
      (type_to_var_annot (name_of_ty storage_type))
      ~default:default_storage_annot
  in
  let arg_type_full =
    Pair_t
      ( (arg_type, None, arg_annot),
        (storage_type, None, storage_annot),
        None,
        has_big_map arg_type || has_big_map storage_type )
  in
  let ret_type_full =
    Pair_t
      ( (List_t (Operation_t None, None, false), None, None),
        (storage_type, None, None),
        None,
        has_big_map storage_type )
  in
  let result =
    parse_returning
      (Toplevel
         {
           storage_type;
           param_type = arg_type;
           root_name;
           legacy_create_contract_literal = false;
         })
      ctxt
      ~legacy
      ~type_logger:(fun loc bef aft ->
        type_map := (loc, (bef, aft)) :: !type_map)
      (arg_type_full, None)
      ret_type_full
      code_field
  in
  trace (Ill_typed_contract (code, !type_map)) result
  >>=? fun (Lam _, ctxt) -> return (!type_map, ctxt)

let typecheck_data :
    ?type_logger:type_logger ->
    context ->
    Script.expr * Script.expr ->
    context tzresult Lwt.t =
 fun ?type_logger ctxt (data, exp_ty) ->
  let legacy = false in
  trace
    (Ill_formed_type (None, exp_ty, 0))
    (Lwt.return @@ parse_packable_ty ctxt ~legacy (root exp_ty))
  >>=? fun (Ex_ty exp_ty, ctxt) ->
  trace_eval
    (fun () ->
      Lwt.return @@ serialize_ty_for_error ctxt exp_ty
      >>|? fun (exp_ty, _ctxt) -> Ill_typed_data (None, data, exp_ty))
    (parse_data ?type_logger ctxt ~legacy exp_ty (root data))
  >>=? fun (_, ctxt) -> return ctxt

module Entrypoints_map = Map.Make (String)

let list_entrypoints (type full) (full : full ty) ctxt ~root_name =
  let merge path annot (type t) (ty : t ty) reachable
      ((unreachables, all) as acc) =
    match annot with
    | None | Some (`Field_annot "") -> (
        ok
        @@
        if reachable then acc
        else
          match ty with
          | Union_t _ ->
              acc
          | _ ->
              (List.rev path :: unreachables, all) )
    | Some (`Field_annot name) ->
        if Compare.Int.(String.length name > 31) then
          ok (List.rev path :: unreachables, all)
        else if Entrypoints_map.mem name all then
          ok (List.rev path :: unreachables, all)
        else
          unparse_ty_no_lwt ctxt ty
          >>? fun (unparsed_ty, _) ->
          ok
            ( unreachables,
              Entrypoints_map.add name (List.rev path, unparsed_ty) all )
  in
  let rec fold_tree :
      type t.
      t ty ->
      prim list ->
      bool ->
      prim list list * (prim list * Script.node) Entrypoints_map.t ->
      (prim list list * (prim list * Script.node) Entrypoints_map.t) tzresult =
   fun t path reachable acc ->
    match t with
    | Union_t ((tl, al), (tr, ar), _, _) ->
        merge (D_Left :: path) al tl reachable acc
        >>? fun acc ->
        merge (D_Right :: path) ar tr reachable acc
        >>? fun acc ->
        fold_tree
          tl
          (D_Left :: path)
          (match al with Some _ -> true | None -> reachable)
          acc
        >>? fun acc ->
        fold_tree
          tr
          (D_Right :: path)
          (match ar with Some _ -> true | None -> reachable)
          acc
    | _ ->
        ok acc
  in
  unparse_ty_no_lwt ctxt full
  >>? fun (unparsed_full, _) ->
  let (init, reachable) =
    match root_name with
    | None | Some "" ->
        (Entrypoints_map.empty, false)
    | Some name ->
        (Entrypoints_map.singleton name ([], unparsed_full), true)
  in
  fold_tree full [] reachable ([], init)

(* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*)

let rec unparse_data :
    type a.
    context ->
    unparsing_mode ->
    a ty ->
    a ->
    (Script.node * context) tzresult Lwt.t =
 fun ctxt mode ty a ->
  Lwt.return (Gas.consume ctxt Unparse_costs.cycle)
  >>=? fun ctxt ->
  match (ty, a) with
  | (Unit_t _, ()) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.unit)
      >>=? fun ctxt -> return (Prim (-1, D_Unit, [], []), ctxt)
  | (Int_t _, v) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.int v))
      >>=? fun ctxt -> return (Int (-1, Script_int.to_zint v), ctxt)
  | (Nat_t _, v) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.int v))
      >>=? fun ctxt -> return (Int (-1, Script_int.to_zint v), ctxt)
  | (String_t _, s) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.string s))
      >>=? fun ctxt -> return (String (-1, s), ctxt)
  | (Bytes_t _, s) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s))
      >>=? fun ctxt -> return (Bytes (-1, s), ctxt)
  | (Bool_t _, true) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.bool)
      >>=? fun ctxt -> return (Prim (-1, D_True, [], []), ctxt)
  | (Bool_t _, false) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.bool)
      >>=? fun ctxt -> return (Prim (-1, D_False, [], []), ctxt)
  | (Timestamp_t _, t) -> (
      Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t))
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          return (Int (-1, Script_timestamp.to_zint t), ctxt)
      | Readable -> (
        match Script_timestamp.to_notation t with
        | None ->
            return (Int (-1, Script_timestamp.to_zint t), ctxt)
        | Some s ->
            return (String (-1, s), ctxt) ) )
  | (Address_t _, (c, entrypoint)) -> (
      Lwt.return (Gas.consume ctxt Unparse_costs.contract)
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          let entrypoint =
            match entrypoint with "default" -> "" | name -> name
          in
          let bytes =
            Data_encoding.Binary.to_bytes_exn
              Data_encoding.(tup2 Contract.encoding Variable.string)
              (c, entrypoint)
          in
          return (Bytes (-1, bytes), ctxt)
      | Readable ->
          let notation =
            match entrypoint with
            | "default" ->
                Contract.to_b58check c
            | entrypoint ->
                Contract.to_b58check c ^ "%" ^ entrypoint
          in
          return (String (-1, notation), ctxt) )
  | (Contract_t _, (_, (c, entrypoint))) -> (
      Lwt.return (Gas.consume ctxt Unparse_costs.contract)
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          let entrypoint =
            match entrypoint with "default" -> "" | name -> name
          in
          let bytes =
            Data_encoding.Binary.to_bytes_exn
              Data_encoding.(tup2 Contract.encoding Variable.string)
              (c, entrypoint)
          in
          return (Bytes (-1, bytes), ctxt)
      | Readable ->
          let notation =
            match entrypoint with
            | "default" ->
                Contract.to_b58check c
            | entrypoint ->
                Contract.to_b58check c ^ "%" ^ entrypoint
          in
          return (String (-1, notation), ctxt) )
  | (Signature_t _, s) -> (
      Lwt.return (Gas.consume ctxt Unparse_costs.signature)
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in
          return (Bytes (-1, bytes), ctxt)
      | Readable ->
          return (String (-1, Signature.to_b58check s), ctxt) )
  | (Mutez_t _, v) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.tez)
      >>=? fun ctxt -> return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt)
  | (Key_t _, k) -> (
      Lwt.return (Gas.consume ctxt Unparse_costs.key)
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          let bytes =
            Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k
          in
          return (Bytes (-1, bytes), ctxt)
      | Readable ->
          return (String (-1, Signature.Public_key.to_b58check k), ctxt) )
  | (Key_hash_t _, k) -> (
      Lwt.return (Gas.consume ctxt Unparse_costs.key_hash)
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          let bytes =
            Data_encoding.Binary.to_bytes_exn
              Signature.Public_key_hash.encoding
              k
          in
          return (Bytes (-1, bytes), ctxt)
      | Readable ->
          return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) )
  | (Operation_t _, (op, _big_map_diff)) ->
      let bytes =
        Data_encoding.Binary.to_bytes_exn
          Operation.internal_operation_encoding
          op
      in
      Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes))
      >>=? fun ctxt -> return (Bytes (-1, bytes), ctxt)
  | (Chain_id_t _, chain_id) ->
      let bytes =
        Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id
      in
      Lwt.return (Gas.consume ctxt (Unparse_costs.chain_id bytes))
      >>=? fun ctxt -> return (Bytes (-1, bytes), ctxt)
  | (Pair_t ((tl, _, _), (tr, _, _), _, _), (l, r)) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.pair)
      >>=? fun ctxt ->
      unparse_data ctxt mode tl l
      >>=? fun (l, ctxt) ->
      unparse_data ctxt mode tr r
      >>=? fun (r, ctxt) -> return (Prim (-1, D_Pair, [l; r], []), ctxt)
  | (Union_t ((tl, _), _, _, _), L l) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.union)
      >>=? fun ctxt ->
      unparse_data ctxt mode tl l
      >>=? fun (l, ctxt) -> return (Prim (-1, D_Left, [l], []), ctxt)
  | (Union_t (_, (tr, _), _, _), R r) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.union)
      >>=? fun ctxt ->
      unparse_data ctxt mode tr r
      >>=? fun (r, ctxt) -> return (Prim (-1, D_Right, [r], []), ctxt)
  | (Option_t (t, _, _), Some v) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.some)
      >>=? fun ctxt ->
      unparse_data ctxt mode t v
      >>=? fun (v, ctxt) -> return (Prim (-1, D_Some, [v], []), ctxt)
  | (Option_t _, None) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.none)
      >>=? fun ctxt -> return (Prim (-1, D_None, [], []), ctxt)
  | (List_t (t, _, _), items) ->
      fold_left_s
        (fun (l, ctxt) element ->
          Lwt.return (Gas.consume ctxt Unparse_costs.list_element)
          >>=? fun ctxt ->
          unparse_data ctxt mode t element
          >>=? fun (unparsed, ctxt) -> return (unparsed :: l, ctxt))
        ([], ctxt)
        items
      >>=? fun (items, ctxt) ->
      return (Micheline.Seq (-1, List.rev items), ctxt)
  | (Set_t (t, _), set) ->
      let t = ty_of_comparable_ty t in
      fold_left_s
        (fun (l, ctxt) item ->
          Lwt.return (Gas.consume ctxt Unparse_costs.set_element)
          >>=? fun ctxt ->
          unparse_data ctxt mode t item
          >>=? fun (item, ctxt) -> return (item :: l, ctxt))
        ([], ctxt)
        (set_fold (fun e acc -> e :: acc) set [])
      >>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt)
  | (Map_t (kt, vt, _, _), map) ->
      let kt = ty_of_comparable_ty kt in
      fold_left_s
        (fun (l, ctxt) (k, v) ->
          Lwt.return (Gas.consume ctxt Unparse_costs.map_element)
          >>=? fun ctxt ->
          unparse_data ctxt mode kt k
          >>=? fun (key, ctxt) ->
          unparse_data ctxt mode vt v
          >>=? fun (value, ctxt) ->
          return (Prim (-1, D_Elt, [key; value], []) :: l, ctxt))
        ([], ctxt)
        (map_fold (fun k v acc -> (k, v) :: acc) map [])
      >>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt)
  | (Big_map_t (kt, vt, _), {id = None; diff = (module Diff); _}) ->
      (* this branch is to allow roundtrip of big map literals *)
      let kt = ty_of_comparable_ty kt in
      fold_left_s
        (fun (l, ctxt) (k, v) ->
          Lwt.return (Gas.consume ctxt Unparse_costs.map_element)
          >>=? fun ctxt ->
          unparse_data ctxt mode kt k
          >>=? fun (key, ctxt) ->
          unparse_data ctxt mode vt v
          >>=? fun (value, ctxt) ->
          return (Prim (-1, D_Elt, [key; value], []) :: l, ctxt))
        ([], ctxt)
        (Diff.OPS.fold
           (fun k v acc ->
             match v with None -> acc | Some v -> (k, v) :: acc)
           (fst Diff.boxed)
           [])
      >>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt)
  | (Big_map_t (_kt, _kv, _), {id = Some id; diff = (module Diff); _}) ->
      if Compare.Int.(Diff.OPS.cardinal (fst Diff.boxed) = 0) then
        return (Micheline.Int (-1, id), ctxt)
      else
        (* this can only be the result of an execution and the map
             must have been flushed at this point *)
        assert false
  | (Lambda_t _, Lam (_, original_code)) ->
      unparse_code ctxt mode original_code

(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *)
and unparse_code ctxt mode =
  let legacy = true in
  function
  | Prim (loc, I_PUSH, [ty; data], annot) ->
      Lwt.return (parse_packable_ty ctxt ~legacy ty)
      >>=? fun (Ex_ty t, ctxt) ->
      parse_data ctxt ~legacy t data
      >>=? fun (data, ctxt) ->
      unparse_data ctxt mode t data
      >>=? fun (data, ctxt) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot))
      >>=? fun ctxt -> return (Prim (loc, I_PUSH, [ty; data], annot), ctxt)
  | Seq (loc, items) ->
      fold_left_s
        (fun (l, ctxt) item ->
          unparse_code ctxt mode item
          >>=? fun (item, ctxt) -> return (item :: l, ctxt))
        ([], ctxt)
        items
      >>=? fun (items, ctxt) ->
      Lwt.return
        (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items)))
      >>=? fun ctxt -> return (Micheline.Seq (loc, List.rev items), ctxt)
  | Prim (loc, prim, items, annot) ->
      fold_left_s
        (fun (l, ctxt) item ->
          unparse_code ctxt mode item
          >>=? fun (item, ctxt) -> return (item :: l, ctxt))
        ([], ctxt)
        items
      >>=? fun (items, ctxt) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot))
      >>=? fun ctxt -> return (Prim (loc, prim, List.rev items, annot), ctxt)
  | (Int _ | String _ | Bytes _) as atom ->
      return (atom, ctxt)

(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *)
let unparse_script ctxt mode {code; arg_type; storage; storage_type; root_name}
    =
  let (Lam (_, original_code)) = code in
  unparse_code ctxt mode original_code
  >>=? fun (code, ctxt) ->
  unparse_data ctxt mode storage_type storage
  >>=? fun (storage, ctxt) ->
  unparse_ty ctxt arg_type
  >>=? fun (arg_type, ctxt) ->
  unparse_ty ctxt storage_type
  >>=? fun (storage_type, ctxt) ->
  let arg_type =
    add_field_annot
      (Option.map ~f:(fun n -> `Field_annot n) root_name)
      None
      arg_type
  in
  let open Micheline in
  let code =
    Seq
      ( -1,
        [ Prim (-1, K_parameter, [arg_type], []);
          Prim (-1, K_storage, [storage_type], []);
          Prim (-1, K_code, [code], []) ] )
  in
  Lwt.return
    ( Gas.consume ctxt (Unparse_costs.seq_cost 3)
    >>? fun ctxt ->
    Gas.consume ctxt (Unparse_costs.prim_cost 1 [])
    >>? fun ctxt ->
    Gas.consume ctxt (Unparse_costs.prim_cost 1 [])
    >>? fun ctxt -> Gas.consume ctxt (Unparse_costs.prim_cost 1 []) )
  >>=? fun ctxt ->
  return
    ( {
        code = lazy_expr (strip_locations code);
        storage = lazy_expr (strip_locations storage);
      },
      ctxt )

let pack_data ctxt typ data =
  unparse_data ctxt Optimized typ data
  >>=? fun (unparsed, ctxt) ->
  let bytes =
    Data_encoding.Binary.to_bytes_exn
      expr_encoding
      (Micheline.strip_locations unparsed)
  in
  Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes)
  >>=? fun ctxt ->
  let bytes = MBytes.concat "" [MBytes.of_string "\005"; bytes] in
  Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes)
  >>=? fun ctxt -> return (bytes, ctxt)

let hash_data ctxt typ data =
  pack_data ctxt typ data
  >>=? fun (bytes, ctxt) ->
  Lwt.return
  @@ Gas.consume
       ctxt
       (Michelson_v1_gas.Cost_of.Legacy.hash bytes Script_expr_hash.size)
  >>=? fun ctxt -> return (Script_expr_hash.(hash_bytes [bytes]), ctxt)

(* ---------------- Big map -------------------------------------------------*)

let empty_big_map tk tv =
  {
    id = None;
    diff = empty_map tk;
    key_type = ty_of_comparable_ty tk;
    value_type = tv;
  }

let big_map_mem ctxt key {id; diff; key_type; _} =
  match (map_get key diff, id) with
  | (None, None) ->
      return (false, ctxt)
  | (None, Some id) ->
      hash_data ctxt key_type key
      >>=? fun (hash, ctxt) ->
      Alpha_context.Big_map.mem ctxt id hash
      >>=? fun (ctxt, res) -> return (res, ctxt)
  | (Some None, _) ->
      return (false, ctxt)
  | (Some (Some _), _) ->
      return (true, ctxt)

let big_map_get ctxt key {id; diff; key_type; value_type} =
  match (map_get key diff, id) with
  | (Some x, _) ->
      return (x, ctxt)
  | (None, None) ->
      return (None, ctxt)
  | (None, Some id) -> (
      hash_data ctxt key_type key
      >>=? fun (hash, ctxt) ->
      Alpha_context.Big_map.get_opt ctxt id hash
      >>=? function
      | (ctxt, None) ->
          return (None, ctxt)
      | (ctxt, Some value) ->
          parse_data ctxt ~legacy:true value_type (Micheline.root value)
          >>=? fun (x, ctxt) -> return (Some x, ctxt) )

let big_map_update key value ({diff; _} as map) =
  {map with diff = map_set key value diff}

module Ids = Set.Make (Compare.Z)

type big_map_ids = Ids.t

let no_big_map_id = Ids.empty

let diff_of_big_map ctxt fresh mode ~ids {id; key_type; value_type; diff} =
  Lwt.return
    (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list diff))
  >>=? fun ctxt ->
  ( match id with
  | Some id ->
      if Ids.mem id ids then
        fresh ctxt
        >>=? fun (ctxt, duplicate) ->
        return (ctxt, [Contract.Copy (id, duplicate)], duplicate)
      else
        (* The first occurence encountered of a big_map reuses the
             ID. This way, the payer is only charged for the diff.
             For this to work, this diff has to be put at the end of
             the global diff, otherwise the duplicates will use the
             updated version as a base. This is true because we add
             this diff first in the accumulator of
             `extract_big_map_updates`, and this accumulator is not
             reversed before being flattened. *)
        return (ctxt, [], id)
  | None ->
      fresh ctxt
      >>=? fun (ctxt, id) ->
      unparse_ty ctxt key_type
      >>=? fun (kt, ctxt) ->
      unparse_ty ctxt value_type
      >>=? fun (kv, ctxt) ->
      return
        ( ctxt,
          [ Contract.Alloc
              {
                big_map = id;
                key_type = Micheline.strip_locations kt;
                value_type = Micheline.strip_locations kv;
              } ],
          id ) )
  >>=? fun (ctxt, init, big_map) ->
  let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in
  fold_left_s
    (fun (acc, ctxt) (key, value) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
      >>=? fun ctxt ->
      hash_data ctxt key_type key
      >>=? fun (diff_key_hash, ctxt) ->
      unparse_data ctxt mode key_type key
      >>=? fun (key_node, ctxt) ->
      let diff_key = Micheline.strip_locations key_node in
      ( match value with
      | None ->
          return (None, ctxt)
      | Some x ->
          unparse_data ctxt mode value_type x
          >>=? fun (node, ctxt) ->
          return (Some (Micheline.strip_locations node), ctxt) )
      >>=? fun (diff_value, ctxt) ->
      let diff_item =
        Contract.Update {big_map; diff_key; diff_key_hash; diff_value}
      in
      return (diff_item :: acc, ctxt))
    ([], ctxt)
    pairs
  >>=? fun (diff, ctxt) -> return (init @ diff, big_map, ctxt)

let rec extract_big_map_updates :
    type a.
    context ->
    (context -> (context * Big_map.id) tzresult Lwt.t) ->
    unparsing_mode ->
    Ids.t ->
    Contract.big_map_diff list ->
    a ty ->
    a ->
    (context * a * Ids.t * Contract.big_map_diff list) tzresult Lwt.t =
 fun ctxt fresh mode ids acc ty x ->
  match (ty, x) with
  | (Big_map_t (_, _, _), map) ->
      diff_of_big_map ctxt fresh mode ids map
      >>=? fun (diff, id, ctxt) ->
      let (module Map) = map.diff in
      let map = {map with diff = empty_map Map.key_ty; id = Some id} in
      return (ctxt, map, Ids.add id ids, diff :: acc)
  | (Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr)) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
      >>=? fun ctxt ->
      extract_big_map_updates ctxt fresh mode ids acc tyl xl
      >>=? fun (ctxt, xl, ids, acc) ->
      extract_big_map_updates ctxt fresh mode ids acc tyr xr
      >>=? fun (ctxt, xr, ids, acc) -> return (ctxt, (xl, xr), ids, acc)
  | (Union_t ((ty, _), (_, _), _, true), L x) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
      >>=? fun ctxt ->
      extract_big_map_updates ctxt fresh mode ids acc ty x
      >>=? fun (ctxt, x, ids, acc) -> return (ctxt, L x, ids, acc)
  | (Union_t ((_, _), (ty, _), _, true), R x) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
      >>=? fun ctxt ->
      extract_big_map_updates ctxt fresh mode ids acc ty x
      >>=? fun (ctxt, x, ids, acc) -> return (ctxt, R x, ids, acc)
  | (Option_t (ty, _, true), Some x) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
      >>=? fun ctxt ->
      extract_big_map_updates ctxt fresh mode ids acc ty x
      >>=? fun (ctxt, x, ids, acc) -> return (ctxt, Some x, ids, acc)
  | (List_t (ty, _, true), l) ->
      fold_left_s
        (fun (ctxt, l, ids, acc) x ->
          Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
          >>=? fun ctxt ->
          extract_big_map_updates ctxt fresh mode ids acc ty x
          >>=? fun (ctxt, x, ids, acc) -> return (ctxt, x :: l, ids, acc))
        (ctxt, [], ids, acc)
        l
      >>=? fun (ctxt, l, ids, acc) -> return (ctxt, List.rev l, ids, acc)
  | (Map_t (_, ty, _, true), ((module M) as m)) ->
      Lwt.return
        (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list m))
      >>=? fun ctxt ->
      fold_left_s
        (fun (ctxt, m, ids, acc) (k, x) ->
          Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
          >>=? fun ctxt ->
          extract_big_map_updates ctxt fresh mode ids acc ty x
          >>=? fun (ctxt, x, ids, acc) ->
          return (ctxt, M.OPS.add k x m, ids, acc))
        (ctxt, M.OPS.empty, ids, acc)
        (M.OPS.bindings (fst M.boxed))
      >>=? fun (ctxt, m, ids, acc) ->
      let module M = struct
        module OPS = M.OPS

        type key = M.key

        type value = M.value

        let key_ty = M.key_ty

        let boxed = (m, snd M.boxed)
      end in
      return
        ( ctxt,
          (module M : Boxed_map with type key = M.key and type value = M.value),
          ids,
          acc )
  | (Option_t (_, _, true), None) ->
      return (ctxt, None, ids, acc)
  | (List_t (_, _, false), v) ->
      return (ctxt, v, ids, acc)
  | (Map_t (_, _, _, false), v) ->
      return (ctxt, v, ids, acc)
  | (Option_t (_, _, false), None) ->
      return (ctxt, None, ids, acc)
  | (Pair_t (_, _, _, false), v) ->
      return (ctxt, v, ids, acc)
  | (Union_t (_, _, _, false), v) ->
      return (ctxt, v, ids, acc)
  | (Option_t (_, _, false), v) ->
      return (ctxt, v, ids, acc)
  | (Chain_id_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Set_t (_, _), v) ->
      return (ctxt, v, ids, acc)
  | (Unit_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Int_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Nat_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Signature_t _, v) ->
      return (ctxt, v, ids, acc)
  | (String_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Bytes_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Mutez_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Key_hash_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Key_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Timestamp_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Address_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Bool_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Lambda_t (_, _, _), v) ->
      return (ctxt, v, ids, acc)
  | (Contract_t (_, _), v) ->
      return (ctxt, v, ids, acc)
  | (Operation_t _, _) ->
      assert false

(* called only on parameters and storage, which cannot contain operations *)

let collect_big_maps ctxt ty x =
  let rec collect :
      type a. context -> a ty -> a -> Ids.t -> (Ids.t * context) tzresult =
   fun ctxt ty x acc ->
    match (ty, x) with
    | (Big_map_t (_, _, _), {id = Some id}) ->
        Gas.consume ctxt Typecheck_costs.cycle
        >>? fun ctxt -> ok (Ids.add id acc, ctxt)
    | (Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr)) ->
        collect ctxt tyl xl acc >>? fun (acc, ctxt) -> collect ctxt tyr xr acc
    | (Union_t ((ty, _), (_, _), _, true), L x) ->
        collect ctxt ty x acc
    | (Union_t ((_, _), (ty, _), _, true), R x) ->
        collect ctxt ty x acc
    | (Option_t (ty, _, true), Some x) ->
        collect ctxt ty x acc
    | (List_t (ty, _, true), l) ->
        List.fold_left
          (fun acc x -> acc >>? fun (acc, ctxt) -> collect ctxt ty x acc)
          (ok (acc, ctxt))
          l
    | (Map_t (_, ty, _, true), m) ->
        map_fold
          (fun _ v acc -> acc >>? fun (acc, ctxt) -> collect ctxt ty v acc)
          m
          (ok (acc, ctxt))
    | (List_t (_, _, false), _) ->
        ok (acc, ctxt)
    | (Map_t (_, _, _, false), _) ->
        ok (acc, ctxt)
    | (Big_map_t (_, _, _), {id = None}) ->
        ok (acc, ctxt)
    | (Option_t (_, _, true), None) ->
        ok (acc, ctxt)
    | (Option_t (_, _, false), _) ->
        ok (acc, ctxt)
    | (Union_t (_, _, _, false), _) ->
        ok (acc, ctxt)
    | (Pair_t (_, _, _, false), _) ->
        ok (acc, ctxt)
    | (Chain_id_t _, _) ->
        ok (acc, ctxt)
    | (Set_t (_, _), _) ->
        ok (acc, ctxt)
    | (Unit_t _, _) ->
        ok (acc, ctxt)
    | (Int_t _, _) ->
        ok (acc, ctxt)
    | (Nat_t _, _) ->
        ok (acc, ctxt)
    | (Signature_t _, _) ->
        ok (acc, ctxt)
    | (String_t _, _) ->
        ok (acc, ctxt)
    | (Bytes_t _, _) ->
        ok (acc, ctxt)
    | (Mutez_t _, _) ->
        ok (acc, ctxt)
    | (Key_hash_t _, _) ->
        ok (acc, ctxt)
    | (Key_t _, _) ->
        ok (acc, ctxt)
    | (Timestamp_t _, _) ->
        ok (acc, ctxt)
    | (Address_t _, _) ->
        ok (acc, ctxt)
    | (Bool_t _, _) ->
        ok (acc, ctxt)
    | (Lambda_t (_, _, _), _) ->
        ok (acc, ctxt)
    | (Contract_t (_, _), _) ->
        ok (acc, ctxt)
    | (Operation_t _, _) ->
        assert false
   (* called only on parameters and storage, which cannot contain operations *)
  in
  Lwt.return (collect ctxt ty x no_big_map_id)

let extract_big_map_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v =
  let to_duplicate = Ids.diff to_duplicate to_update in
  let fresh =
    if temporary then fun c -> return (Big_map.fresh_temporary c)
    else Big_map.fresh
  in
  extract_big_map_updates ctxt fresh mode to_duplicate [] ty v
  >>=? fun (ctxt, v, alive, diffs) ->
  let diffs =
    if temporary then diffs
    else
      let dead = Ids.diff to_update alive in
      Ids.fold (fun id acc -> Contract.Clear id :: acc) dead [] :: diffs
  in
  match diffs with
  | [] ->
      return (v, None, ctxt)
  | diffs ->
      return (v, Some (List.flatten diffs (* do not reverse *)), ctxt)

let list_of_big_map_ids ids = Ids.elements ids
Script_ir_translator.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Michelson_v1_gas.
Require Tezos.Script_expr_hash.
Require Tezos.Script_ir_annot.
Require Tezos.Script_tc_errors.
Require Tezos.Script_typed_ir.

Import Alpha_context.

Import Micheline.

Import Script.

Import Script_typed_ir.

Import Script_tc_errors.

Import Script_ir_annot.

Module Typecheck_costs := Michelson_v1_gas.Cost_of.Typechecking.

Module Unparse_costs := Michelson_v1_gas.Cost_of.Unparse.

Reserved Notation "'ex_comparable_ty".

Inductive ex_comparable_ty_gadt : Set :=
| Ex_comparable_ty : forall {a : Set},
  Script_typed_ir.comparable_ty a -> ex_comparable_ty_gadt

where "'ex_comparable_ty" := (ex_comparable_ty_gadt).

Definition ex_comparable_ty := 'ex_comparable_ty.

Reserved Notation "'ex_ty".

Inductive ex_ty_gadt : Set :=
| Ex_ty : forall {a : Set}, Script_typed_ir.ty a -> ex_ty_gadt

where "'ex_ty" := (ex_ty_gadt).

Definition ex_ty := 'ex_ty.

Reserved Notation "'ex_stack_ty".

Inductive ex_stack_ty_gadt : Set :=
| Ex_stack_ty : forall {a : Set}, Script_typed_ir.stack_ty a -> ex_stack_ty_gadt

where "'ex_stack_ty" := (ex_stack_ty_gadt).

Definition ex_stack_ty := 'ex_stack_ty.

Module tc_context.
  Module Toplevel.
    Record record {storage_type param_type root_name
      legacy_create_contract_literal : Set} := {
      storage_type : storage_type;
      param_type : param_type;
      root_name : root_name;
      legacy_create_contract_literal : legacy_create_contract_literal }.
    Arguments record : clear implicits.
  End Toplevel.
  Definition Toplevel_skeleton := Toplevel.record.
End tc_context.

Reserved Notation "'tc_context.Toplevel".
Reserved Notation "'tc_context".

Inductive tc_context_gadt : Set :=
| Lambda : tc_context_gadt
| Dip : forall {a : Set},
  Script_typed_ir.stack_ty a -> tc_context_gadt -> tc_context_gadt
| Toplevel : forall {param sto : Set},
  'tc_context.Toplevel param sto -> tc_context_gadt

where "'tc_context" := (tc_context_gadt)
and "'tc_context.Toplevel" := (fun (t_param t_sto : Set) =>
  tc_context.Toplevel_skeleton (Script_typed_ir.ty t_sto)
    (Script_typed_ir.ty t_param) (option string) bool).

Module ConstructorRecordNotations_tc_context_gadt.
  Module tc_context.
    Definition Toplevel := 'tc_context.Toplevel.
  End tc_context.
End ConstructorRecordNotations_tc_context_gadt.
Import ConstructorRecordNotations_tc_context_gadt.

Definition tc_context := 'tc_context.

Inductive unparsing_mode : Set :=
| Optimized : unparsing_mode
| Readable : unparsing_mode.

Definition type_logger :=
  Z -> list (Alpha_context.Script.expr * Alpha_context.Script.annot) ->
  list (Alpha_context.Script.expr * Alpha_context.Script.annot) -> unit.

Definition add_dip {A : Set}
  (ty : Script_typed_ir.ty A) (annot : option Script_typed_ir.var_annot)
  (prev : tc_context) : tc_context :=
  match prev with
  | Lambda | Toplevel _ =>
    Dip (Script_typed_ir.Item_t ty Script_typed_ir.Empty_t annot) prev
  | Dip stack _ => Dip (Script_typed_ir.Item_t ty stack annot) prev
  end.

Fixpoint comparable_type_size {a t : Set}
  (ty : Script_typed_ir.comparable_struct t a) {struct ty} : Z :=
  match ty with
  | Script_typed_ir.Int_key _ => 1
  | Script_typed_ir.Nat_key _ => 1
  | Script_typed_ir.String_key _ => 1
  | Script_typed_ir.Bytes_key _ => 1
  | Script_typed_ir.Mutez_key _ => 1
  | Script_typed_ir.Bool_key _ => 1
  | Script_typed_ir.Key_hash_key _ => 1
  | Script_typed_ir.Timestamp_key _ => 1
  | Script_typed_ir.Address_key _ => 1
  | Script_typed_ir.Pair_key _ (__t_value, _) _ =>
    Pervasives.op_plus 1 (comparable_type_size __t_value)
  end.

Fixpoint type_size {t : Set} (ty : Script_typed_ir.ty t) {struct ty} : Z :=
  match ty with
  | Script_typed_ir.Unit_t _ => 1
  | Script_typed_ir.Int_t _ => 1
  | Script_typed_ir.Nat_t _ => 1
  | Script_typed_ir.Signature_t _ => 1
  | Script_typed_ir.Bytes_t _ => 1
  | Script_typed_ir.String_t _ => 1
  | Script_typed_ir.Mutez_t _ => 1
  | Script_typed_ir.Key_hash_t _ => 1
  | Script_typed_ir.Key_t _ => 1
  | Script_typed_ir.Timestamp_t _ => 1
  | Script_typed_ir.Address_t _ => 1
  | Script_typed_ir.Bool_t _ => 1
  | Script_typed_ir.Operation_t _ => 1
  | Script_typed_ir.Pair_t (l, _, _) (r, _, _) _ _ =>
    Pervasives.op_plus (Pervasives.op_plus 1 (type_size l)) (type_size r)
  | Script_typed_ir.Union_t (l, _) (r, _) _ _ =>
    Pervasives.op_plus (Pervasives.op_plus 1 (type_size l)) (type_size r)
  | Script_typed_ir.Lambda_t arg ret _ =>
    Pervasives.op_plus (Pervasives.op_plus 1 (type_size arg)) (type_size ret)
  | Script_typed_ir.Option_t __t_value _ _ =>
    Pervasives.op_plus 1 (type_size __t_value)
  | Script_typed_ir.List_t __t_value _ _ =>
    Pervasives.op_plus 1 (type_size __t_value)
  | Script_typed_ir.Set_t k _ => Pervasives.op_plus 1 (comparable_type_size k)
  | Script_typed_ir.Map_t k v _ _ =>
    Pervasives.op_plus (Pervasives.op_plus 1 (comparable_type_size k))
      (type_size v)
  | Script_typed_ir.Big_map_t k v _ =>
    Pervasives.op_plus (Pervasives.op_plus 1 (comparable_type_size k))
      (type_size v)
  | Script_typed_ir.Contract_t arg _ => Pervasives.op_plus 1 (type_size arg)
  | Script_typed_ir.Chain_id_t _ => 1
  end.

Fixpoint type_size_of_stack_head {st : Set}
  (stack : Script_typed_ir.stack_ty st) (up_to : Z) {struct stack} : Z :=
  match stack with
  | Script_typed_ir.Empty_t => 0
  | Script_typed_ir.Item_t head tail _annot =>
    if (|Compare.Int|).(Compare.S.op_gt) up_to 0 then
      (|Compare.Int|).(Compare.S.max) (type_size head)
        (type_size_of_stack_head tail (Pervasives.op_minus up_to 1))
    else
      0
  end.

Definition number_of_generated_growing_types {a b : Set}
  (function_parameter : Script_typed_ir.instr b a) : Z :=
  match function_parameter with
  | Script_typed_ir.Drop => 0
  | Script_typed_ir.Dup => 0
  | Script_typed_ir.Swap => 0
  | Script_typed_ir.Const _ => 1
  | Script_typed_ir.Cons_pair => 1
  | Script_typed_ir.Car => 0
  | Script_typed_ir.Cdr => 0
  | Script_typed_ir.Cons_some => 1
  | Script_typed_ir.Cons_none _ => 1
  | Script_typed_ir.If_none _ _ => 0
  | Script_typed_ir.Left => 0
  | Script_typed_ir.Right => 0
  | Script_typed_ir.If_left _ _ => 0
  | Script_typed_ir.Cons_list => 1
  | Script_typed_ir.Nil => 1
  | Script_typed_ir.If_cons _ _ => 0
  | Script_typed_ir.List_map _ => 1
  | Script_typed_ir.List_size => 0
  | Script_typed_ir.List_iter _ => 1
  | Script_typed_ir.Empty_set _ => 1
  | Script_typed_ir.Set_iter _ => 0
  | Script_typed_ir.Set_mem => 0
  | Script_typed_ir.Set_update => 0
  | Script_typed_ir.Set_size => 0
  | Script_typed_ir.Empty_map _ _ => 1
  | Script_typed_ir.Map_map _ => 1
  | Script_typed_ir.Map_iter _ => 1
  | Script_typed_ir.Map_mem => 0
  | Script_typed_ir.Map_get => 0
  | Script_typed_ir.Map_update => 0
  | Script_typed_ir.Map_size => 0
  | Script_typed_ir.Empty_big_map _ _ => 1
  | Script_typed_ir.Big_map_get => 0
  | Script_typed_ir.Big_map_update => 0
  | Script_typed_ir.Big_map_mem => 0
  | Script_typed_ir.Concat_string => 0
  | Script_typed_ir.Concat_string_pair => 0
  | Script_typed_ir.Slice_string => 0
  | Script_typed_ir.String_size => 0
  | Script_typed_ir.Concat_bytes => 0
  | Script_typed_ir.Concat_bytes_pair => 0
  | Script_typed_ir.Slice_bytes => 0
  | Script_typed_ir.Bytes_size => 0
  | Script_typed_ir.Add_seconds_to_timestamp => 0
  | Script_typed_ir.Add_timestamp_to_seconds => 0
  | Script_typed_ir.Sub_timestamp_seconds => 0
  | Script_typed_ir.Diff_timestamps => 0
  | Script_typed_ir.Add_tez => 0
  | Script_typed_ir.Sub_tez => 0
  | Script_typed_ir.Mul_teznat => 0
  | Script_typed_ir.Mul_nattez => 0
  | Script_typed_ir.Ediv_teznat => 0
  | Script_typed_ir.Ediv_tez => 0
  | Script_typed_ir.Or => 0
  | Script_typed_ir.And => 0
  | Script_typed_ir.Xor => 0
  | Script_typed_ir.Not => 0
  | Script_typed_ir.Is_nat => 0
  | Script_typed_ir.Neg_nat => 0
  | Script_typed_ir.Neg_int => 0
  | Script_typed_ir.Abs_int => 0
  | Script_typed_ir.Int_nat => 0
  | Script_typed_ir.Add_intint => 0
  | Script_typed_ir.Add_intnat => 0
  | Script_typed_ir.Add_natint => 0
  | Script_typed_ir.Add_natnat => 0
  | Script_typed_ir.Sub_int => 0
  | Script_typed_ir.Mul_intint => 0
  | Script_typed_ir.Mul_intnat => 0
  | Script_typed_ir.Mul_natint => 0
  | Script_typed_ir.Mul_natnat => 0
  | Script_typed_ir.Ediv_intint => 0
  | Script_typed_ir.Ediv_intnat => 0
  | Script_typed_ir.Ediv_natint => 0
  | Script_typed_ir.Ediv_natnat => 0
  | Script_typed_ir.Lsl_nat => 0
  | Script_typed_ir.Lsr_nat => 0
  | Script_typed_ir.Or_nat => 0
  | Script_typed_ir.And_nat => 0
  | Script_typed_ir.And_int_nat => 0
  | Script_typed_ir.Xor_nat => 0
  | Script_typed_ir.Not_nat => 0
  | Script_typed_ir.Not_int => 0
  | Script_typed_ir.Seq _ _ => 0
  | Script_typed_ir.If _ _ => 0
  | Script_typed_ir.Loop _ => 0
  | Script_typed_ir.Loop_left _ => 0
  | Script_typed_ir.Dip _ => 0
  | Script_typed_ir.Exec => 0
  | Script_typed_ir.Apply _ => 0
  | Script_typed_ir.Lambda _ => 1
  | Script_typed_ir.Failwith _ => 1
  | Script_typed_ir.Nop => 0
  | Script_typed_ir.Compare _ => 1
  | Script_typed_ir.Eq => 0
  | Script_typed_ir.Neq => 0
  | Script_typed_ir.Lt => 0
  | Script_typed_ir.Gt => 0
  | Script_typed_ir.Le => 0
  | Script_typed_ir.Ge => 0
  | Script_typed_ir.Address => 0
  | Script_typed_ir.Contract _ _ => 1
  | Script_typed_ir.Transfer_tokens => 1
  | Script_typed_ir.Create_account => 0
  | Script_typed_ir.Implicit_account => 0
  | Script_typed_ir.Create_contract _ _ _ _ => 1
  | Script_typed_ir.Create_contract_2 _ _ _ _ => 1
  | Script_typed_ir.Now => 0
  | Script_typed_ir.Balance => 0
  | Script_typed_ir.Check_signature => 0
  | Script_typed_ir.Hash_key => 0
  | Script_typed_ir.Blake2b => 0
  | Script_typed_ir.Sha256 => 0
  | Script_typed_ir.Sha512 => 0
  | Script_typed_ir.Steps_to_quota => 0
  | Script_typed_ir.Source => 0
  | Script_typed_ir.Sender => 0
  | Script_typed_ir.Self _ _ => 1
  | Script_typed_ir.Amount => 0
  | Script_typed_ir.Set_delegate => 0
  | Script_typed_ir.Pack _ => 0
  | Script_typed_ir.Unpack _ => 1
  | Script_typed_ir.Dig _ _ => 0
  | Script_typed_ir.Dug _ _ => 0
  | Script_typed_ir.Dipn _ _ _ => 0
  | Script_typed_ir.Dropn _ _ => 0
  | Script_typed_ir.ChainId => 0
  end.

Definition location {A B : Set} (function_parameter : Micheline.node A B) : A :=
  let
    'Micheline.Prim loc _ _ _ | Micheline.Int loc _ | Micheline.String loc _ |
    Micheline.Bytes loc _ | Micheline.Seq loc _ := function_parameter in
  loc.

Definition kind {A B : Set} (function_parameter : Micheline.node A B)
  : Script_tc_errors.kind :=
  match function_parameter with
  | Micheline.Int _ _ => Script_tc_errors.Int_kind
  | Micheline.String _ _ => Script_tc_errors.String_kind
  | Micheline.Bytes _ _ => Script_tc_errors.Bytes_kind
  | Micheline.Prim _ _ _ _ => Script_tc_errors.Prim_kind
  | Micheline.Seq _ _ => Script_tc_errors.Seq_kind
  end.

Definition namespace (function_parameter : Alpha_context.Script.prim)
  : Script_tc_errors.namespace :=
  match function_parameter with
  |
    Alpha_context.Script.K_parameter | Alpha_context.Script.K_storage |
    Alpha_context.Script.K_code => Script_tc_errors.Keyword_namespace
  |
    Alpha_context.Script.D_False | Alpha_context.Script.D_Elt |
    Alpha_context.Script.D_Left | Alpha_context.Script.D_None |
    Alpha_context.Script.D_Pair | Alpha_context.Script.D_Right |
    Alpha_context.Script.D_Some | Alpha_context.Script.D_True |
    Alpha_context.Script.D_Unit => Script_tc_errors.Constant_namespace
  |
    Alpha_context.Script.I_PACK | Alpha_context.Script.I_UNPACK |
    Alpha_context.Script.I_BLAKE2B | Alpha_context.Script.I_SHA256 |
    Alpha_context.Script.I_SHA512 | Alpha_context.Script.I_ABS |
    Alpha_context.Script.I_ADD | Alpha_context.Script.I_AMOUNT |
    Alpha_context.Script.I_AND | Alpha_context.Script.I_BALANCE |
    Alpha_context.Script.I_CAR | Alpha_context.Script.I_CDR |
    Alpha_context.Script.I_CHAIN_ID | Alpha_context.Script.I_CHECK_SIGNATURE |
    Alpha_context.Script.I_COMPARE | Alpha_context.Script.I_CONCAT |
    Alpha_context.Script.I_CONS | Alpha_context.Script.I_CREATE_ACCOUNT |
    Alpha_context.Script.I_CREATE_CONTRACT |
    Alpha_context.Script.I_IMPLICIT_ACCOUNT | Alpha_context.Script.I_DIP |
    Alpha_context.Script.I_DROP | Alpha_context.Script.I_DUP |
    Alpha_context.Script.I_EDIV | Alpha_context.Script.I_EMPTY_BIG_MAP |
    Alpha_context.Script.I_EMPTY_MAP | Alpha_context.Script.I_EMPTY_SET |
    Alpha_context.Script.I_EQ | Alpha_context.Script.I_EXEC |
    Alpha_context.Script.I_APPLY | Alpha_context.Script.I_FAILWITH |
    Alpha_context.Script.I_GE | Alpha_context.Script.I_GET |
    Alpha_context.Script.I_GT | Alpha_context.Script.I_HASH_KEY |
    Alpha_context.Script.I_IF | Alpha_context.Script.I_IF_CONS |
    Alpha_context.Script.I_IF_LEFT | Alpha_context.Script.I_IF_NONE |
    Alpha_context.Script.I_INT | Alpha_context.Script.I_LAMBDA |
    Alpha_context.Script.I_LE | Alpha_context.Script.I_LEFT |
    Alpha_context.Script.I_LOOP | Alpha_context.Script.I_LSL |
    Alpha_context.Script.I_LSR | Alpha_context.Script.I_LT |
    Alpha_context.Script.I_MAP | Alpha_context.Script.I_MEM |
    Alpha_context.Script.I_MUL | Alpha_context.Script.I_NEG |
    Alpha_context.Script.I_NEQ | Alpha_context.Script.I_NIL |
    Alpha_context.Script.I_NONE | Alpha_context.Script.I_NOT |
    Alpha_context.Script.I_NOW | Alpha_context.Script.I_OR |
    Alpha_context.Script.I_PAIR | Alpha_context.Script.I_PUSH |
    Alpha_context.Script.I_RIGHT | Alpha_context.Script.I_SIZE |
    Alpha_context.Script.I_SOME | Alpha_context.Script.I_SOURCE |
    Alpha_context.Script.I_SENDER | Alpha_context.Script.I_SELF |
    Alpha_context.Script.I_SLICE | Alpha_context.Script.I_STEPS_TO_QUOTA |
    Alpha_context.Script.I_SUB | Alpha_context.Script.I_SWAP |
    Alpha_context.Script.I_TRANSFER_TOKENS | Alpha_context.Script.I_SET_DELEGATE
    | Alpha_context.Script.I_UNIT | Alpha_context.Script.I_UPDATE |
    Alpha_context.Script.I_XOR | Alpha_context.Script.I_ITER |
    Alpha_context.Script.I_LOOP_LEFT | Alpha_context.Script.I_ADDRESS |
    Alpha_context.Script.I_CONTRACT | Alpha_context.Script.I_ISNAT |
    Alpha_context.Script.I_CAST | Alpha_context.Script.I_RENAME |
    Alpha_context.Script.I_DIG | Alpha_context.Script.I_DUG =>
    Script_tc_errors.Instr_namespace
  |
    Alpha_context.Script.T_bool | Alpha_context.Script.T_contract |
    Alpha_context.Script.T_int | Alpha_context.Script.T_key |
    Alpha_context.Script.T_key_hash | Alpha_context.Script.T_lambda |
    Alpha_context.Script.T_list | Alpha_context.Script.T_map |
    Alpha_context.Script.T_big_map | Alpha_context.Script.T_nat |
    Alpha_context.Script.T_option | Alpha_context.Script.T_or |
    Alpha_context.Script.T_pair | Alpha_context.Script.T_set |
    Alpha_context.Script.T_signature | Alpha_context.Script.T_string |
    Alpha_context.Script.T_bytes | Alpha_context.Script.T_mutez |
    Alpha_context.Script.T_timestamp | Alpha_context.Script.T_unit |
    Alpha_context.Script.T_operation | Alpha_context.Script.T_address |
    Alpha_context.Script.T_chain_id => Script_tc_errors.Type_namespace
  end.

Definition unexpected
  (expr : Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
  (exp_kinds : list Script_tc_errors.kind) (exp_ns : Script_tc_errors.namespace)
  (exp_prims : list Alpha_context.Script.prim) : Error_monad.__error :=
  match expr with
  | Micheline.Int loc _ => extensible_type_value
  | Micheline.String loc _ => extensible_type_value
  | Micheline.Bytes loc _ => extensible_type_value
  | Micheline.Seq loc _ => extensible_type_value
  | Micheline.Prim loc name _ _ =>
    match ((namespace name), exp_ns) with
    |
      (Script_tc_errors.Type_namespace, Script_tc_errors.Type_namespace) |
      (Script_tc_errors.Instr_namespace, Script_tc_errors.Instr_namespace) |
      (Script_tc_errors.Constant_namespace, Script_tc_errors.Constant_namespace)
      => extensible_type_value
    | (ns, _) => extensible_type_value
    end
  end.

Definition check_kind {A : Set}
  (kinds : list Script_tc_errors.kind)
  (expr : Micheline.node Alpha_context.Script.location A)
  : Lwt.t (Error_monad.tzresult unit) :=
  let kind := kind expr in
  if List.mem kind kinds then
    Error_monad.return_unit
  else
    let loc := location expr in
    Error_monad.fail extensible_type_value.

Definition wrap_compare {A B : Set}
  (compare : A -> B -> (|Compare.Int|).(Compare.S.t)) (a : A) (b : B) : Z :=
  let res := compare a b in
  if (|Compare.Int|).(Compare.S.op_eq) res 0 then
    0
  else
    if (|Compare.Int|).(Compare.S.op_gt) res 0 then
      1
    else
      (-1).

Fixpoint compare_comparable {a s : Set}
  (kind : Script_typed_ir.comparable_struct a s) {struct kind} : a -> a -> Z :=
  match kind with
  | Script_typed_ir.String_key _ =>
    wrap_compare (|Compare.String|).(Compare.S.compare)
  | Script_typed_ir.Bool_key _ =>
    wrap_compare (|Compare.Bool|).(Compare.S.compare)
  | Script_typed_ir.Mutez_key _ => wrap_compare Alpha_context.Tez.compare
  | Script_typed_ir.Key_hash_key _ =>
    wrap_compare (|Signature.Public_key_hash|).(S.SPublic_key_hash.compare)
  | Script_typed_ir.Int_key _ => wrap_compare Alpha_context.Script_int.compare
  | Script_typed_ir.Nat_key _ => wrap_compare Alpha_context.Script_int.compare
  | Script_typed_ir.Timestamp_key _ =>
    wrap_compare Alpha_context.Script_timestamp.compare
  | Script_typed_ir.Address_key _ =>
    Pervasives.op_atat wrap_compare
      (fun function_parameter =>
        let '(x, ex) := function_parameter in
        fun function_parameter =>
          let '(y, ey) := function_parameter in
          let lres := Alpha_context.Contract.compare x y in
          if (|Compare.Int|).(Compare.S.op_eq) lres 0 then
            (|Compare.String|).(Compare.S.compare) ex ey
          else
            lres)
  | Script_typed_ir.Bytes_key _ => wrap_compare MBytes.compare
  | Script_typed_ir.Pair_key (tl, _) (tr, _) _ =>
    fun function_parameter =>
      let '(lx, rx) := function_parameter in
      fun function_parameter =>
        let '(ly, ry) := function_parameter in
        let lres := compare_comparable tl lx ly in
        if (|Compare.Int|).(Compare.S.op_eq) lres 0 then
          compare_comparable tr rx ry
        else
          lres
  end.

Definition empty_set {a : Set} (ty : Script_typed_ir.comparable_ty a)
  : Script_typed_ir.set a :=
  let OPS :=
    __Set.Make
      (let t := a in
      let compare := compare_comparable ty in
      existT _ _
        {|
          Compare.COMPARABLE.compare := compare
        |}) in
  let elt := a in
  let elt_ty := ty in
  let boxed := (|OPS|).(S.SET.empty) in
  let size := 0 in
  existT _ _
    {|
      Script_typed_ir.Boxed_set.elt_ty := elt_ty;
      Script_typed_ir.Boxed_set.boxed := boxed;
      Script_typed_ir.Boxed_set.size := size
    |}.

Definition set_update {a : Set} (v : a) (b : bool) (Box : Script_typed_ir.set a)
  : Script_typed_ir.set a :=
  let elt := a in
  let elt_ty := (|Box|).(Script_typed_ir.Boxed_set.elt_ty) in
  let OPS := (|Box|).(Script_typed_ir.Boxed_set.OPS) in
  let boxed :=
    if b then
      (|Box|).(Script_typed_ir.Boxed_set.OPS).(S.SET.add) v
        (|Box|).(Script_typed_ir.Boxed_set.boxed)
    else
      (|Box|).(Script_typed_ir.Boxed_set.OPS).(S.SET.remove) v
        (|Box|).(Script_typed_ir.Boxed_set.boxed) in
  let size :=
    let mem :=
      (|Box|).(Script_typed_ir.Boxed_set.OPS).(S.SET.mem) v
        (|Box|).(Script_typed_ir.Boxed_set.boxed) in
    if mem then
      if b then
        (|Box|).(Script_typed_ir.Boxed_set.size)
      else
        Pervasives.op_minus (|Box|).(Script_typed_ir.Boxed_set.size) 1
    else
      if b then
        Pervasives.op_plus (|Box|).(Script_typed_ir.Boxed_set.size) 1
      else
        (|Box|).(Script_typed_ir.Boxed_set.size) in
  existT _ _
    {|
      Script_typed_ir.Boxed_set.elt_ty := elt_ty;
      Script_typed_ir.Boxed_set.boxed := boxed;
      Script_typed_ir.Boxed_set.size := size
    |}.

Definition set_mem {elt : Set} (v : elt) (Box : Script_typed_ir.set elt)
  : bool :=
  (|Box|).(Script_typed_ir.Boxed_set.OPS).(S.SET.mem) v
    (|Box|).(Script_typed_ir.Boxed_set.boxed).

Definition set_fold {acc elt : Set}
  (f : elt -> acc -> acc) (Box : Script_typed_ir.set elt) : acc -> acc :=
  (|Box|).(Script_typed_ir.Boxed_set.OPS).(S.SET.fold) f
    (|Box|).(Script_typed_ir.Boxed_set.boxed).

Definition set_size {elt : Set} (Box : Script_typed_ir.set elt)
  : Alpha_context.Script_int.num Alpha_context.Script_int.n :=
  Alpha_context.Script_int.abs
    (Alpha_context.Script_int.of_int (|Box|).(Script_typed_ir.Boxed_set.size)).

Definition map_key_ty {a b : Set} (Box : Script_typed_ir.map a b)
  : Script_typed_ir.comparable_ty a :=
  (|Box|).(Script_typed_ir.Boxed_map.key_ty).

Definition empty_map {a b : Set} (ty : Script_typed_ir.comparable_ty a)
  : Script_typed_ir.map a b :=
  let OPS :=
    Map.Make
      (let t := a in
      let compare := compare_comparable ty in
      existT _ _
        {|
          Compare.COMPARABLE.compare := compare
        |}) in
  let key := a in
  let value := b in
  let key_ty := ty in
  let boxed := ((|OPS|).(S.MAP.empty), 0) in
  existT _ _
    {|
      Script_typed_ir.Boxed_map.key_ty := key_ty;
      Script_typed_ir.Boxed_map.boxed := boxed
    |}.

Definition map_get {key value : Set}
  (k : key) (Box : Script_typed_ir.map key value) : option value :=
  (|Box|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.find_opt) k
    (Pervasives.fst (|Box|).(Script_typed_ir.Boxed_map.boxed)).

Definition map_update {a b : Set}
  (k : a) (v : option b) (Box : Script_typed_ir.map a b)
  : Script_typed_ir.map a b :=
  let key := a in
  let value := b in
  let key_ty := (|Box|).(Script_typed_ir.Boxed_map.key_ty) in
  let OPS := (|Box|).(Script_typed_ir.Boxed_map.OPS) in
  let boxed :=
    let '(map, size) := (|Box|).(Script_typed_ir.Boxed_map.boxed) in
    let contains := (|Box|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.mem) k map in
    match v with
    | Some v =>
      (((|Box|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.add) k v map),
        (Pervasives.op_plus size
          (if contains then
            0
          else
            1)))
    | None =>
      (((|Box|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.remove) k map),
        (Pervasives.op_minus size
          (if contains then
            1
          else
            0)))
    end in
  existT _ _
    {|
      Script_typed_ir.Boxed_map.key_ty := key_ty;
      Script_typed_ir.Boxed_map.boxed := boxed
    |}.

Definition map_set {a b : Set} (k : a) (v : b) (Box : Script_typed_ir.map a b)
  : Script_typed_ir.map a b :=
  let key := a in
  let value := b in
  let key_ty := (|Box|).(Script_typed_ir.Boxed_map.key_ty) in
  let OPS := (|Box|).(Script_typed_ir.Boxed_map.OPS) in
  let boxed :=
    let '(map, size) := (|Box|).(Script_typed_ir.Boxed_map.boxed) in
    (((|Box|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.add) k v map),
      (if (|Box|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.mem) k map then
        size
      else
        Pervasives.op_plus size 1)) in
  existT _ _
    {|
      Script_typed_ir.Boxed_map.key_ty := key_ty;
      Script_typed_ir.Boxed_map.boxed := boxed
    |}.

Definition map_mem {key value : Set}
  (k : key) (Box : Script_typed_ir.map key value) : bool :=
  (|Box|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.mem) k
    (Pervasives.fst (|Box|).(Script_typed_ir.Boxed_map.boxed)).

Definition map_fold {acc key value : Set}
  (f : key -> value -> acc -> acc) (Box : Script_typed_ir.map key value)
  : acc -> acc :=
  (|Box|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.fold) f
    (Pervasives.fst (|Box|).(Script_typed_ir.Boxed_map.boxed)).

Definition map_size {key value : Set} (Box : Script_typed_ir.map key value)
  : Alpha_context.Script_int.num Alpha_context.Script_int.n :=
  Alpha_context.Script_int.abs
    (Alpha_context.Script_int.of_int
      (Pervasives.snd (|Box|).(Script_typed_ir.Boxed_map.boxed))).

Fixpoint ty_of_comparable_ty {a s : Set}
  (function_parameter : Script_typed_ir.comparable_struct a s)
  {struct function_parameter} : Script_typed_ir.ty a :=
  match function_parameter with
  | Script_typed_ir.Int_key tname => Script_typed_ir.Int_t tname
  | Script_typed_ir.Nat_key tname => Script_typed_ir.Nat_t tname
  | Script_typed_ir.String_key tname => Script_typed_ir.String_t tname
  | Script_typed_ir.Bytes_key tname => Script_typed_ir.Bytes_t tname
  | Script_typed_ir.Mutez_key tname => Script_typed_ir.Mutez_t tname
  | Script_typed_ir.Bool_key tname => Script_typed_ir.Bool_t tname
  | Script_typed_ir.Key_hash_key tname => Script_typed_ir.Key_hash_t tname
  | Script_typed_ir.Timestamp_key tname => Script_typed_ir.Timestamp_t tname
  | Script_typed_ir.Address_key tname => Script_typed_ir.Address_t tname
  | Script_typed_ir.Pair_key (l, al) (r, ar) tname =>
    Script_typed_ir.Pair_t ((ty_of_comparable_ty l), al, None)
      ((ty_of_comparable_ty r), ar, None) tname false
  end.

Fixpoint comparable_ty_of_ty {a : Set}
  (function_parameter : Script_typed_ir.ty a) {struct function_parameter}
  : option (Script_typed_ir.comparable_ty a) :=
  match function_parameter with
  | Script_typed_ir.Int_t tname => Some (Script_typed_ir.Int_key tname)
  | Script_typed_ir.Nat_t tname => Some (Script_typed_ir.Nat_key tname)
  | Script_typed_ir.String_t tname => Some (Script_typed_ir.String_key tname)
  | Script_typed_ir.Bytes_t tname => Some (Script_typed_ir.Bytes_key tname)
  | Script_typed_ir.Mutez_t tname => Some (Script_typed_ir.Mutez_key tname)
  | Script_typed_ir.Bool_t tname => Some (Script_typed_ir.Bool_key tname)
  | Script_typed_ir.Key_hash_t tname =>
    Some (Script_typed_ir.Key_hash_key tname)
  | Script_typed_ir.Timestamp_t tname =>
    Some (Script_typed_ir.Timestamp_key tname)
  | Script_typed_ir.Address_t tname => Some (Script_typed_ir.Address_key tname)
  | Script_typed_ir.Pair_t (l, al, _) (r, ar, _) pname _ =>
    match comparable_ty_of_ty r with
    | None => None
    | Some rty =>
      match comparable_ty_of_ty l with
      | None => None
      | Some (Script_typed_ir.Pair_key _ _ _) => None
      | Some (Script_typed_ir.Int_key tname) =>
        Some
          (Script_typed_ir.Pair_key ((Script_typed_ir.Int_key tname), al)
            (rty, ar) pname)
      | Some (Script_typed_ir.Nat_key tname) =>
        Some
          (Script_typed_ir.Pair_key ((Script_typed_ir.Nat_key tname), al)
            (rty, ar) pname)
      | Some (Script_typed_ir.String_key tname) =>
        Some
          (Script_typed_ir.Pair_key ((Script_typed_ir.String_key tname), al)
            (rty, ar) pname)
      | Some (Script_typed_ir.Bytes_key tname) =>
        Some
          (Script_typed_ir.Pair_key ((Script_typed_ir.Bytes_key tname), al)
            (rty, ar) pname)
      | Some (Script_typed_ir.Mutez_key tname) =>
        Some
          (Script_typed_ir.Pair_key ((Script_typed_ir.Mutez_key tname), al)
            (rty, ar) pname)
      | Some (Script_typed_ir.Bool_key tname) =>
        Some
          (Script_typed_ir.Pair_key ((Script_typed_ir.Bool_key tname), al)
            (rty, ar) pname)
      | Some (Script_typed_ir.Key_hash_key tname) =>
        Some
          (Script_typed_ir.Pair_key ((Script_typed_ir.Key_hash_key tname), al)
            (rty, ar) pname)
      | Some (Script_typed_ir.Timestamp_key tname) =>
        Some
          (Script_typed_ir.Pair_key ((Script_typed_ir.Timestamp_key tname), al)
            (rty, ar) pname)
      | Some (Script_typed_ir.Address_key tname) =>
        Some
          (Script_typed_ir.Pair_key ((Script_typed_ir.Address_key tname), al)
            (rty, ar) pname)
      end
    end
  | _ => None
  end.

Definition add_field_annot {A B : Set}
  (a : option Script_typed_ir.field_annot)
  (var : option Script_typed_ir.var_annot)
  (function_parameter : Micheline.node A B) : Micheline.node A B :=
  match function_parameter with
  | Micheline.Prim loc prim args annots =>
    Micheline.Prim loc prim args
      (Pervasives.op_at annots
        (Pervasives.op_at (Script_ir_annot.unparse_field_annot a)
          (Script_ir_annot.unparse_var_annot var)))
  | expr => expr
  end.

Fixpoint unparse_comparable_ty {a s : Set}
  (function_parameter : Script_typed_ir.comparable_struct a s)
  {struct function_parameter} : Alpha_context.Script.node :=
  match function_parameter with
  | Script_typed_ir.Int_key tname =>
    Micheline.Prim (-1) Alpha_context.Script.T_int []
      (Script_ir_annot.unparse_type_annot tname)
  | Script_typed_ir.Nat_key tname =>
    Micheline.Prim (-1) Alpha_context.Script.T_nat []
      (Script_ir_annot.unparse_type_annot tname)
  | Script_typed_ir.String_key tname =>
    Micheline.Prim (-1) Alpha_context.Script.T_string []
      (Script_ir_annot.unparse_type_annot tname)
  | Script_typed_ir.Bytes_key tname =>
    Micheline.Prim (-1) Alpha_context.Script.T_bytes []
      (Script_ir_annot.unparse_type_annot tname)
  | Script_typed_ir.Mutez_key tname =>
    Micheline.Prim (-1) Alpha_context.Script.T_mutez []
      (Script_ir_annot.unparse_type_annot tname)
  | Script_typed_ir.Bool_key tname =>
    Micheline.Prim (-1) Alpha_context.Script.T_bool []
      (Script_ir_annot.unparse_type_annot tname)
  | Script_typed_ir.Key_hash_key tname =>
    Micheline.Prim (-1) Alpha_context.Script.T_key_hash []
      (Script_ir_annot.unparse_type_annot tname)
  | Script_typed_ir.Timestamp_key tname =>
    Micheline.Prim (-1) Alpha_context.Script.T_timestamp []
      (Script_ir_annot.unparse_type_annot tname)
  | Script_typed_ir.Address_key tname =>
    Micheline.Prim (-1) Alpha_context.Script.T_address []
      (Script_ir_annot.unparse_type_annot tname)
  | Script_typed_ir.Pair_key (l, al) (r, ar) pname =>
    let tl := add_field_annot al None (unparse_comparable_ty l) in
    let tr := add_field_annot ar None (unparse_comparable_ty r) in
    Micheline.Prim (-1) Alpha_context.Script.T_pair [ tl; tr ]
      (Script_ir_annot.unparse_type_annot pname)
  end.

Fixpoint unparse_ty_no_lwt {a : Set}
  (ctxt : Alpha_context.context) (ty : Script_typed_ir.ty a) {struct ctxt}
  : Error_monad.tzresult (Alpha_context.Script.node * Alpha_context.context) :=
  Error_monad.op_gtgtquestion
    (Alpha_context.Gas.consume ctxt Unparse_costs.cycle)
    (fun ctxt =>
      let __return {B : Set}
        (ctxt : Alpha_context.context)
        (function_parameter : B * list (Micheline.node Z B) * Micheline.annot)
        : Error_monad.tzresult (Micheline.node Z B * Alpha_context.context) :=
        let '(name, args, annot) := function_parameter in
        let __result_value := Micheline.Prim (-1) name args annot in
        Error_monad.op_gtgtquestion
          (Alpha_context.Gas.consume ctxt
            (Unparse_costs.prim_cost (List.length args) annot))
          (fun ctxt => Error_monad.ok (__result_value, ctxt)) in
      match ty with
      | Script_typed_ir.Unit_t tname =>
        __return ctxt
          (Alpha_context.Script.T_unit, [],
            (Script_ir_annot.unparse_type_annot tname))
      | Script_typed_ir.Int_t tname =>
        __return ctxt
          (Alpha_context.Script.T_int, [],
            (Script_ir_annot.unparse_type_annot tname))
      | Script_typed_ir.Nat_t tname =>
        __return ctxt
          (Alpha_context.Script.T_nat, [],
            (Script_ir_annot.unparse_type_annot tname))
      | Script_typed_ir.String_t tname =>
        __return ctxt
          (Alpha_context.Script.T_string, [],
            (Script_ir_annot.unparse_type_annot tname))
      | Script_typed_ir.Bytes_t tname =>
        __return ctxt
          (Alpha_context.Script.T_bytes, [],
            (Script_ir_annot.unparse_type_annot tname))
      | Script_typed_ir.Mutez_t tname =>
        __return ctxt
          (Alpha_context.Script.T_mutez, [],
            (Script_ir_annot.unparse_type_annot tname))
      | Script_typed_ir.Bool_t tname =>
        __return ctxt
          (Alpha_context.Script.T_bool, [],
            (Script_ir_annot.unparse_type_annot tname))
      | Script_typed_ir.Key_hash_t tname =>
        __return ctxt
          (Alpha_context.Script.T_key_hash, [],
            (Script_ir_annot.unparse_type_annot tname))
      | Script_typed_ir.Key_t tname =>
        __return ctxt
          (Alpha_context.Script.T_key, [],
            (Script_ir_annot.unparse_type_annot tname))
      | Script_typed_ir.Timestamp_t tname =>
        __return ctxt
          (Alpha_context.Script.T_timestamp, [],
            (Script_ir_annot.unparse_type_annot tname))
      | Script_typed_ir.Address_t tname =>
        __return ctxt
          (Alpha_context.Script.T_address, [],
            (Script_ir_annot.unparse_type_annot tname))
      | Script_typed_ir.Signature_t tname =>
        __return ctxt
          (Alpha_context.Script.T_signature, [],
            (Script_ir_annot.unparse_type_annot tname))
      | Script_typed_ir.Operation_t tname =>
        __return ctxt
          (Alpha_context.Script.T_operation, [],
            (Script_ir_annot.unparse_type_annot tname))
      | Script_typed_ir.Chain_id_t tname =>
        __return ctxt
          (Alpha_context.Script.T_chain_id, [],
            (Script_ir_annot.unparse_type_annot tname))
      | Script_typed_ir.Contract_t ut tname =>
        Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt ut)
          (fun function_parameter =>
            let '(__t_value, ctxt) := function_parameter in
            __return ctxt
              (Alpha_context.Script.T_contract, [ __t_value ],
                (Script_ir_annot.unparse_type_annot tname)))
      |
        Script_typed_ir.Pair_t (utl, l_field, l_var) (utr, r_field, r_var) tname
          _ =>
        let annot := Script_ir_annot.unparse_type_annot tname in
        Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt utl)
          (fun function_parameter =>
            let '(utl, ctxt) := function_parameter in
            let tl := add_field_annot l_field l_var utl in
            Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
              (fun function_parameter =>
                let '(utr, ctxt) := function_parameter in
                let tr := add_field_annot r_field r_var utr in
                __return ctxt (Alpha_context.Script.T_pair, [ tl; tr ], annot)))
      | Script_typed_ir.Union_t (utl, l_field) (utr, r_field) tname _ =>
        let annot := Script_ir_annot.unparse_type_annot tname in
        Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt utl)
          (fun function_parameter =>
            let '(utl, ctxt) := function_parameter in
            let tl := add_field_annot l_field None utl in
            Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
              (fun function_parameter =>
                let '(utr, ctxt) := function_parameter in
                let tr := add_field_annot r_field None utr in
                __return ctxt (Alpha_context.Script.T_or, [ tl; tr ], annot)))
      | Script_typed_ir.Lambda_t uta utr tname =>
        Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt uta)
          (fun function_parameter =>
            let '(ta, ctxt) := function_parameter in
            Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
              (fun function_parameter =>
                let '(tr, ctxt) := function_parameter in
                __return ctxt
                  (Alpha_context.Script.T_lambda, [ ta; tr ],
                    (Script_ir_annot.unparse_type_annot tname))))
      | Script_typed_ir.Option_t ut tname _ =>
        let annot := Script_ir_annot.unparse_type_annot tname in
        Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt ut)
          (fun function_parameter =>
            let '(ut, ctxt) := function_parameter in
            __return ctxt (Alpha_context.Script.T_option, [ ut ], annot))
      | Script_typed_ir.List_t ut tname _ =>
        Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt ut)
          (fun function_parameter =>
            let '(__t_value, ctxt) := function_parameter in
            __return ctxt
              (Alpha_context.Script.T_list, [ __t_value ],
                (Script_ir_annot.unparse_type_annot tname)))
      | Script_typed_ir.Set_t ut tname =>
        let __t_value := unparse_comparable_ty ut in
        __return ctxt
          (Alpha_context.Script.T_set, [ __t_value ],
            (Script_ir_annot.unparse_type_annot tname))
      | Script_typed_ir.Map_t uta utr tname _ =>
        let ta := unparse_comparable_ty uta in
        Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
          (fun function_parameter =>
            let '(tr, ctxt) := function_parameter in
            __return ctxt
              (Alpha_context.Script.T_map, [ ta; tr ],
                (Script_ir_annot.unparse_type_annot tname)))
      | Script_typed_ir.Big_map_t uta utr tname =>
        let ta := unparse_comparable_ty uta in
        Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
          (fun function_parameter =>
            let '(tr, ctxt) := function_parameter in
            __return ctxt
              (Alpha_context.Script.T_big_map, [ ta; tr ],
                (Script_ir_annot.unparse_type_annot tname)))
      end).

Definition unparse_ty {A : Set}
  (ctxt : Alpha_context.context) (ty : Script_typed_ir.ty A)
  : Lwt.t
    (Error_monad.tzresult (Alpha_context.Script.node * Alpha_context.context)) :=
  Lwt.__return (unparse_ty_no_lwt ctxt ty).

Fixpoint strip_var_annots {A B : Set} (function_parameter : Micheline.node A B)
  {struct function_parameter} : Micheline.node A B :=
  match function_parameter with
  | (Micheline.Int _ _ | Micheline.String _ _ | Micheline.Bytes _ _) as atom =>
    atom
  | Micheline.Seq loc args => Micheline.Seq loc (List.map strip_var_annots args)
  | Micheline.Prim loc name args annots =>
    let not_var_annot (s : string) : bool :=
      (|Compare.Char|).(Compare.S.op_ltgt) (String.get s 0) "@" % char in
    let annots := List.filter not_var_annot annots in
    Micheline.Prim loc name (List.map strip_var_annots args) annots
  end.

Definition serialize_ty_for_error {A : Set}
  (ctxt : Alpha_context.context) (ty : Script_typed_ir.ty A)
  : Error_monad.tzresult
    (Micheline.canonical Alpha_context.Script.prim * Alpha_context.context) :=
  Error_monad.op_gtpipequestion
    (Pervasives.op_pipegt (unparse_ty_no_lwt ctxt ty)
      (Error_monad.record_trace extensible_type_value))
    (fun function_parameter =>
      let '(ty, ctxt) := function_parameter in
      ((Micheline.strip_locations (strip_var_annots ty)), ctxt)).

Fixpoint unparse_stack {a : Set}
  (ctxt : Alpha_context.context)
  (function_parameter : Script_typed_ir.stack_ty a) {struct ctxt}
  : Lwt.t
    (Error_monad.tzresult
      (list (Alpha_context.Script.expr * Alpha_context.Script.annot) *
        Alpha_context.context)) :=
  match function_parameter with
  | Script_typed_ir.Empty_t => Error_monad.__return ([], ctxt)
  | Script_typed_ir.Item_t ty rest annot =>
    Error_monad.op_gtgteqquestion (unparse_ty ctxt ty)
      (fun function_parameter =>
        let '(uty, ctxt) := function_parameter in
        Error_monad.op_gtgteqquestion (unparse_stack ctxt rest)
          (fun function_parameter =>
            let '(urest, ctxt) := function_parameter in
            Error_monad.__return
              ((cons
                ((Micheline.strip_locations uty),
                  (Script_ir_annot.unparse_var_annot annot)) urest), ctxt)))
  end.

Definition serialize_stack_for_error {A : Set}
  (ctxt : Alpha_context.context) (stack_ty : Script_typed_ir.stack_ty A)
  : Lwt.t
    (Error_monad.tzresult
      (list (Alpha_context.Script.expr * Alpha_context.Script.annot) *
        Alpha_context.context)) :=
  Error_monad.trace extensible_type_value (unparse_stack ctxt stack_ty).

Definition name_of_ty {a : Set} (function_parameter : Script_typed_ir.ty a)
  : option Script_typed_ir.type_annot :=
  match function_parameter with
  | Script_typed_ir.Unit_t tname => tname
  | Script_typed_ir.Int_t tname => tname
  | Script_typed_ir.Nat_t tname => tname
  | Script_typed_ir.String_t tname => tname
  | Script_typed_ir.Bytes_t tname => tname
  | Script_typed_ir.Mutez_t tname => tname
  | Script_typed_ir.Bool_t tname => tname
  | Script_typed_ir.Key_hash_t tname => tname
  | Script_typed_ir.Key_t tname => tname
  | Script_typed_ir.Timestamp_t tname => tname
  | Script_typed_ir.Address_t tname => tname
  | Script_typed_ir.Signature_t tname => tname
  | Script_typed_ir.Operation_t tname => tname
  | Script_typed_ir.Chain_id_t tname => tname
  | Script_typed_ir.Contract_t _ tname => tname
  | Script_typed_ir.Pair_t _ _ tname _ => tname
  | Script_typed_ir.Union_t _ _ tname _ => tname
  | Script_typed_ir.Lambda_t _ _ tname => tname
  | Script_typed_ir.Option_t _ tname _ => tname
  | Script_typed_ir.List_t _ tname _ => tname
  | Script_typed_ir.Set_t _ tname => tname
  | Script_typed_ir.Map_t _ _ tname _ => tname
  | Script_typed_ir.Big_map_t _ _ tname => tname
  end.

Reserved Notation "'eq".

Inductive eq_gadt : Set :=
| Eq : eq_gadt

where "'eq" := (fun (_ _ : Set) => eq_gadt).

Definition eq := 'eq.

Definition comparable_ty_eq {ta tb : Set}
  (ctxt : Alpha_context.context) (ta : Script_typed_ir.comparable_ty ta)
  (tb : Script_typed_ir.comparable_ty tb)
  : Error_monad.tzresult
    (eq (Script_typed_ir.comparable_ty ta) (Script_typed_ir.comparable_ty tb)) :=
  match (ta, tb) with
  | (Script_typed_ir.Int_key _, Script_typed_ir.Int_key _) => Pervasives.Ok Eq
  | (Script_typed_ir.Nat_key _, Script_typed_ir.Nat_key _) => Pervasives.Ok Eq
  | (Script_typed_ir.String_key _, Script_typed_ir.String_key _) =>
    Pervasives.Ok Eq
  | (Script_typed_ir.Bytes_key _, Script_typed_ir.Bytes_key _) =>
    Pervasives.Ok Eq
  | (Script_typed_ir.Mutez_key _, Script_typed_ir.Mutez_key _) =>
    Pervasives.Ok Eq
  | (Script_typed_ir.Bool_key _, Script_typed_ir.Bool_key _) => Pervasives.Ok Eq
  | (Script_typed_ir.Key_hash_key _, Script_typed_ir.Key_hash_key _) =>
    Pervasives.Ok Eq
  | (Script_typed_ir.Timestamp_key _, Script_typed_ir.Timestamp_key _) =>
    Pervasives.Ok Eq
  | (Script_typed_ir.Address_key _, Script_typed_ir.Address_key _) =>
    Pervasives.Ok Eq
  | (_, _) =>
    Error_monad.op_gtgtquestion
      (serialize_ty_for_error ctxt (ty_of_comparable_ty ta))
      (fun function_parameter =>
        let '(ta, ctxt) := function_parameter in
        Error_monad.op_gtgtquestion
          (serialize_ty_for_error ctxt (ty_of_comparable_ty tb))
          (fun function_parameter =>
            let '(tb, _ctxt) := function_parameter in
            Error_monad.__error_value extensible_type_value))
  end.

Definition record_inconsistent {A B C : Set}
  (ctxt : Alpha_context.context) (ta : Script_typed_ir.ty A)
  (tb : Script_typed_ir.ty B)
  : Error_monad.tzresult C -> Error_monad.tzresult C :=
  Error_monad.record_trace_eval
    (fun function_parameter =>
      let '_ := function_parameter in
      Error_monad.op_gtgtquestion (serialize_ty_for_error ctxt ta)
        (fun function_parameter =>
          let '(ta, ctxt) := function_parameter in
          Error_monad.op_gtpipequestion (serialize_ty_for_error ctxt tb)
            (fun function_parameter =>
              let '(tb, _ctxt) := function_parameter in
              extensible_type_value))).

Definition record_inconsistent_type_annotations {A B C : Set}
  (ctxt : Alpha_context.context) (loc : Alpha_context.Script.location)
  (ta : Script_typed_ir.ty A) (tb : Script_typed_ir.ty B)
  : Error_monad.tzresult C -> Error_monad.tzresult C :=
  Error_monad.record_trace_eval
    (fun function_parameter =>
      let '_ := function_parameter in
      Error_monad.op_gtgtquestion (serialize_ty_for_error ctxt ta)
        (fun function_parameter =>
          let '(ta, ctxt) := function_parameter in
          Error_monad.op_gtpipequestion (serialize_ty_for_error ctxt tb)
            (fun function_parameter =>
              let '(tb, _ctxt) := function_parameter in
              extensible_type_value))).

Fixpoint ty_eq {ta tb : Set}
  (ctxt : Alpha_context.context) (ta : Script_typed_ir.ty ta)
  (tb : Script_typed_ir.ty tb) {struct ctxt}
  : Error_monad.tzresult
    (eq (Script_typed_ir.ty ta) (Script_typed_ir.ty tb) * Alpha_context.context) :=
  let ok
    (__eq_value : eq (Script_typed_ir.ty ta) (Script_typed_ir.ty tb))
    (ctxt : Alpha_context.context) (nb_args : Z)
    : Error_monad.tzresult
      (eq (Script_typed_ir.ty ta) (Script_typed_ir.ty tb) *
        Alpha_context.context) :=
    Error_monad.op_gtgtquestion
      (Alpha_context.Gas.consume ctxt
        (Typecheck_costs.type_ (Pervasives.op_star 2 nb_args)))
      (fun ctxt => Pervasives.Ok (__eq_value, ctxt)) in
  Error_monad.op_gtgtquestion
    (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle)
    (fun ctxt =>
      match (ta, tb) with
      | (Script_typed_ir.Unit_t _, Script_typed_ir.Unit_t _) => ok Eq ctxt 0
      | (Script_typed_ir.Int_t _, Script_typed_ir.Int_t _) => ok Eq ctxt 0
      | (Script_typed_ir.Nat_t _, Script_typed_ir.Nat_t _) => ok Eq ctxt 0
      | (Script_typed_ir.Key_t _, Script_typed_ir.Key_t _) => ok Eq ctxt 0
      | (Script_typed_ir.Key_hash_t _, Script_typed_ir.Key_hash_t _) =>
        ok Eq ctxt 0
      | (Script_typed_ir.String_t _, Script_typed_ir.String_t _) => ok Eq ctxt 0
      | (Script_typed_ir.Bytes_t _, Script_typed_ir.Bytes_t _) => ok Eq ctxt 0
      | (Script_typed_ir.Signature_t _, Script_typed_ir.Signature_t _) =>
        ok Eq ctxt 0
      | (Script_typed_ir.Mutez_t _, Script_typed_ir.Mutez_t _) => ok Eq ctxt 0
      | (Script_typed_ir.Timestamp_t _, Script_typed_ir.Timestamp_t _) =>
        ok Eq ctxt 0
      | (Script_typed_ir.Chain_id_t _, Script_typed_ir.Chain_id_t _) =>
        ok Eq ctxt 0
      | (Script_typed_ir.Address_t _, Script_typed_ir.Address_t _) =>
        ok Eq ctxt 0
      | (Script_typed_ir.Bool_t _, Script_typed_ir.Bool_t _) => ok Eq ctxt 0
      | (Script_typed_ir.Operation_t _, Script_typed_ir.Operation_t _) =>
        ok Eq ctxt 0
      | (Script_typed_ir.Map_t tal tar _ _, Script_typed_ir.Map_t tbl tbr _ _)
        =>
        Pervasives.op_pipegt
          (Error_monad.op_gtgtquestion (comparable_ty_eq ctxt tal tbl)
            (fun function_parameter =>
              let 'Eq := function_parameter in
              Error_monad.op_gtgtquestion (ty_eq ctxt tar tbr)
                (fun function_parameter =>
                  let '(Eq, ctxt) := function_parameter in
                  ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
      |
        (Script_typed_ir.Big_map_t tal tar _,
          Script_typed_ir.Big_map_t tbl tbr _) =>
        Pervasives.op_pipegt
          (Error_monad.op_gtgtquestion (comparable_ty_eq ctxt tal tbl)
            (fun function_parameter =>
              let 'Eq := function_parameter in
              Error_monad.op_gtgtquestion (ty_eq ctxt tar tbr)
                (fun function_parameter =>
                  let '(Eq, ctxt) := function_parameter in
                  ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
      | (Script_typed_ir.Set_t ea _, Script_typed_ir.Set_t eb _) =>
        Pervasives.op_pipegt
          (Error_monad.op_gtgtquestion (comparable_ty_eq ctxt ea eb)
            (fun function_parameter =>
              let 'Eq := function_parameter in
              ok Eq ctxt 1)) (record_inconsistent ctxt ta tb)
      |
        (Script_typed_ir.Pair_t (tal, _, _) (tar, _, _) _ _,
          Script_typed_ir.Pair_t (tbl, _, _) (tbr, _, _) _ _) =>
        Pervasives.op_pipegt
          (Error_monad.op_gtgtquestion (ty_eq ctxt tal tbl)
            (fun function_parameter =>
              let '(Eq, ctxt) := function_parameter in
              Error_monad.op_gtgtquestion (ty_eq ctxt tar tbr)
                (fun function_parameter =>
                  let '(Eq, ctxt) := function_parameter in
                  ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
      |
        (Script_typed_ir.Union_t (tal, _) (tar, _) _ _,
          Script_typed_ir.Union_t (tbl, _) (tbr, _) _ _) =>
        Pervasives.op_pipegt
          (Error_monad.op_gtgtquestion (ty_eq ctxt tal tbl)
            (fun function_parameter =>
              let '(Eq, ctxt) := function_parameter in
              Error_monad.op_gtgtquestion (ty_eq ctxt tar tbr)
                (fun function_parameter =>
                  let '(Eq, ctxt) := function_parameter in
                  ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
      | (Script_typed_ir.Lambda_t tal tar _, Script_typed_ir.Lambda_t tbl tbr _)
        =>
        Pervasives.op_pipegt
          (Error_monad.op_gtgtquestion (ty_eq ctxt tal tbl)
            (fun function_parameter =>
              let '(Eq, ctxt) := function_parameter in
              Error_monad.op_gtgtquestion (ty_eq ctxt tar tbr)
                (fun function_parameter =>
                  let '(Eq, ctxt) := function_parameter in
                  ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
      | (Script_typed_ir.Contract_t tal _, Script_typed_ir.Contract_t tbl _) =>
        Pervasives.op_pipegt
          (Error_monad.op_gtgtquestion (ty_eq ctxt tal tbl)
            (fun function_parameter =>
              let '(Eq, ctxt) := function_parameter in
              ok Eq ctxt 1)) (record_inconsistent ctxt ta tb)
      | (Script_typed_ir.Option_t tva _ _, Script_typed_ir.Option_t tvb _ _) =>
        Pervasives.op_pipegt
          (Error_monad.op_gtgtquestion (ty_eq ctxt tva tvb)
            (fun function_parameter =>
              let '(Eq, ctxt) := function_parameter in
              ok Eq ctxt 1)) (record_inconsistent ctxt ta tb)
      | (Script_typed_ir.List_t tva _ _, Script_typed_ir.List_t tvb _ _) =>
        Pervasives.op_pipegt
          (Error_monad.op_gtgtquestion (ty_eq ctxt tva tvb)
            (fun function_parameter =>
              let '(Eq, ctxt) := function_parameter in
              ok Eq ctxt 1)) (record_inconsistent ctxt ta tb)
      | (_, _) =>
        Error_monad.op_gtgtquestion (serialize_ty_for_error ctxt ta)
          (fun function_parameter =>
            let '(ta, ctxt) := function_parameter in
            Error_monad.op_gtgtquestion (serialize_ty_for_error ctxt tb)
              (fun function_parameter =>
                let '(tb, _ctxt) := function_parameter in
                Error_monad.__error_value extensible_type_value))
      end).

Fixpoint stack_ty_eq {ta tb : Set}
  (ctxt : Alpha_context.context) (lvl : Z) (ta : Script_typed_ir.stack_ty ta)
  (tb : Script_typed_ir.stack_ty tb) {struct ctxt}
  : Error_monad.tzresult
    (eq (Script_typed_ir.stack_ty ta) (Script_typed_ir.stack_ty tb) *
      Alpha_context.context) :=
  match (ta, tb) with
  | (Script_typed_ir.Item_t tva ra _, Script_typed_ir.Item_t tvb rb _) =>
    Error_monad.op_gtgtquestion
      (Pervasives.op_pipegt (ty_eq ctxt tva tvb)
        (Error_monad.record_trace extensible_type_value))
      (fun function_parameter =>
        let '(Eq, ctxt) := function_parameter in
        Error_monad.op_gtgtquestion
          (stack_ty_eq ctxt (Pervasives.op_plus lvl 1) ra rb)
          (fun function_parameter =>
            let '(Eq, ctxt) := function_parameter in
            Pervasives.Ok (Eq, ctxt)))
  | (Script_typed_ir.Empty_t, Script_typed_ir.Empty_t) =>
    Pervasives.Ok (Eq, ctxt)
  | (_, _) => Error_monad.__error_value extensible_type_value
  end.

Definition merge_comparable_types {ta : Set}
  (legacy : bool) (ta : Script_typed_ir.comparable_ty ta)
  (tb : Script_typed_ir.comparable_ty ta)
  : Error_monad.tzresult (Script_typed_ir.comparable_ty ta) :=
  match (ta, tb) with
  | (Script_typed_ir.Int_key annot_a, Script_typed_ir.Int_key annot_b) =>
    Error_monad.op_gtpipequestion
      (Script_ir_annot.merge_type_annot legacy annot_a annot_b)
      (fun annot => Script_typed_ir.Int_key annot)
  | (Script_typed_ir.Nat_key annot_a, Script_typed_ir.Nat_key annot_b) =>
    Error_monad.op_gtpipequestion
      (Script_ir_annot.merge_type_annot legacy annot_a annot_b)
      (fun annot => Script_typed_ir.Nat_key annot)
  | (Script_typed_ir.String_key annot_a, Script_typed_ir.String_key annot_b) =>
    Error_monad.op_gtpipequestion
      (Script_ir_annot.merge_type_annot legacy annot_a annot_b)
      (fun annot => Script_typed_ir.String_key annot)
  | (Script_typed_ir.Bytes_key annot_a, Script_typed_ir.Bytes_key annot_b) =>
    Error_monad.op_gtpipequestion
      (Script_ir_annot.merge_type_annot legacy annot_a annot_b)
      (fun annot => Script_typed_ir.Bytes_key annot)
  | (Script_typed_ir.Mutez_key annot_a, Script_typed_ir.Mutez_key annot_b) =>
    Error_monad.op_gtpipequestion
      (Script_ir_annot.merge_type_annot legacy annot_a annot_b)
      (fun annot => Script_typed_ir.Mutez_key annot)
  | (Script_typed_ir.Bool_key annot_a, Script_typed_ir.Bool_key annot_b) =>
    Error_monad.op_gtpipequestion
      (Script_ir_annot.merge_type_annot legacy annot_a annot_b)
      (fun annot => Script_typed_ir.Bool_key annot)
  | (Script_typed_ir.Key_hash_key annot_a, Script_typed_ir.Key_hash_key annot_b)
    =>
    Error_monad.op_gtpipequestion
      (Script_ir_annot.merge_type_annot legacy annot_a annot_b)
      (fun annot => Script_typed_ir.Key_hash_key annot)
  |
    (Script_typed_ir.Timestamp_key annot_a,
      Script_typed_ir.Timestamp_key annot_b) =>
    Error_monad.op_gtpipequestion
      (Script_ir_annot.merge_type_annot legacy annot_a annot_b)
      (fun annot => Script_typed_ir.Timestamp_key annot)
  | (Script_typed_ir.Address_key annot_a, Script_typed_ir.Address_key annot_b)
    =>
    Error_monad.op_gtpipequestion
      (Script_ir_annot.merge_type_annot legacy annot_a annot_b)
      (fun annot => Script_typed_ir.Address_key annot)
  | (_, _) =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  end.

Definition merge_types {b : Set} (legacy : bool)
  : Alpha_context.context -> Alpha_context.Script.location ->
  Script_typed_ir.ty b -> Script_typed_ir.ty b ->
  Error_monad.tzresult (Script_typed_ir.ty b * Alpha_context.context) :=
  let fix help {a : Set}
    (ctxt : Alpha_context.context) (ty1 : Script_typed_ir.ty a)
    (ty2 : Script_typed_ir.ty a) {struct ctxt}
    : Error_monad.tzresult (Script_typed_ir.ty a * Alpha_context.context) :=
    match (ty1, ty2) with
    | (Script_typed_ir.Unit_t tn1, Script_typed_ir.Unit_t tn2) =>
      Error_monad.op_gtpipequestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname => ((Script_typed_ir.Unit_t tname), ctxt))
    | (Script_typed_ir.Int_t tn1, Script_typed_ir.Int_t tn2) =>
      Error_monad.op_gtpipequestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname => ((Script_typed_ir.Int_t tname), ctxt))
    | (Script_typed_ir.Nat_t tn1, Script_typed_ir.Nat_t tn2) =>
      Error_monad.op_gtpipequestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname => ((Script_typed_ir.Nat_t tname), ctxt))
    | (Script_typed_ir.Key_t tn1, Script_typed_ir.Key_t tn2) =>
      Error_monad.op_gtpipequestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname => ((Script_typed_ir.Key_t tname), ctxt))
    | (Script_typed_ir.Key_hash_t tn1, Script_typed_ir.Key_hash_t tn2) =>
      Error_monad.op_gtpipequestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname => ((Script_typed_ir.Key_hash_t tname), ctxt))
    | (Script_typed_ir.String_t tn1, Script_typed_ir.String_t tn2) =>
      Error_monad.op_gtpipequestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname => ((Script_typed_ir.String_t tname), ctxt))
    | (Script_typed_ir.Bytes_t tn1, Script_typed_ir.Bytes_t tn2) =>
      Error_monad.op_gtpipequestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname => ((Script_typed_ir.Bytes_t tname), ctxt))
    | (Script_typed_ir.Signature_t tn1, Script_typed_ir.Signature_t tn2) =>
      Error_monad.op_gtpipequestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname => ((Script_typed_ir.Signature_t tname), ctxt))
    | (Script_typed_ir.Mutez_t tn1, Script_typed_ir.Mutez_t tn2) =>
      Error_monad.op_gtpipequestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname => ((Script_typed_ir.Mutez_t tname), ctxt))
    | (Script_typed_ir.Timestamp_t tn1, Script_typed_ir.Timestamp_t tn2) =>
      Error_monad.op_gtpipequestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname => ((Script_typed_ir.Timestamp_t tname), ctxt))
    | (Script_typed_ir.Address_t tn1, Script_typed_ir.Address_t tn2) =>
      Error_monad.op_gtpipequestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname => ((Script_typed_ir.Address_t tname), ctxt))
    | (Script_typed_ir.Bool_t tn1, Script_typed_ir.Bool_t tn2) =>
      Error_monad.op_gtpipequestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname => ((Script_typed_ir.Bool_t tname), ctxt))
    | (Script_typed_ir.Chain_id_t tn1, Script_typed_ir.Chain_id_t tn2) =>
      Error_monad.op_gtpipequestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname => ((Script_typed_ir.Chain_id_t tname), ctxt))
    | (Script_typed_ir.Operation_t tn1, Script_typed_ir.Operation_t tn2) =>
      Error_monad.op_gtpipequestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname => ((Script_typed_ir.Operation_t tname), ctxt))
    |
      (Script_typed_ir.Map_t tal tar tn1 has_big_map,
        Script_typed_ir.Map_t tbl tbr tn2 _) =>
      Error_monad.op_gtgtquestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname =>
          Error_monad.op_gtgtquestion (help ctxt tar tbr)
            (fun function_parameter =>
              let '(value, ctxt) := function_parameter in
              Error_monad.op_gtgtquestion (ty_eq ctxt tar value)
                (fun function_parameter =>
                  let '(Eq, ctxt) := function_parameter in
                  Error_monad.op_gtpipequestion
                    (merge_comparable_types legacy tal tbl)
                    (fun tk =>
                      ((Script_typed_ir.Map_t tk value tname has_big_map), ctxt)))))
    |
      (Script_typed_ir.Big_map_t tal tar tn1,
        Script_typed_ir.Big_map_t tbl tbr tn2) =>
      Error_monad.op_gtgtquestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname =>
          Error_monad.op_gtgtquestion (help ctxt tar tbr)
            (fun function_parameter =>
              let '(value, ctxt) := function_parameter in
              Error_monad.op_gtgtquestion (ty_eq ctxt tar value)
                (fun function_parameter =>
                  let '(Eq, ctxt) := function_parameter in
                  Error_monad.op_gtpipequestion
                    (merge_comparable_types legacy tal tbl)
                    (fun tk =>
                      ((Script_typed_ir.Big_map_t tk value tname), ctxt)))))
    | (Script_typed_ir.Set_t ea tn1, Script_typed_ir.Set_t eb tn2) =>
      Error_monad.op_gtgtquestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname =>
          Error_monad.op_gtpipequestion (merge_comparable_types legacy ea eb)
            (fun e => ((Script_typed_ir.Set_t e tname), ctxt)))
    |
      (Script_typed_ir.Pair_t (tal, l_field1, l_var1) (tar, r_field1, r_var1)
        tn1 has_big_map,
        Script_typed_ir.Pair_t (tbl, l_field2, l_var2) (tbr, r_field2, r_var2)
          tn2 _) =>
      Error_monad.op_gtgtquestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname =>
          Error_monad.op_gtgtquestion
            (Script_ir_annot.merge_field_annot legacy l_field1 l_field2)
            (fun l_field =>
              Error_monad.op_gtgtquestion
                (Script_ir_annot.merge_field_annot legacy r_field1 r_field2)
                (fun r_field =>
                  let l_var := Script_ir_annot.merge_var_annot l_var1 l_var2 in
                  let r_var := Script_ir_annot.merge_var_annot r_var1 r_var2 in
                  Error_monad.op_gtgtquestion (help ctxt tal tbl)
                    (fun function_parameter =>
                      let '(left_ty, ctxt) := function_parameter in
                      Error_monad.op_gtpipequestion (help ctxt tar tbr)
                        (fun function_parameter =>
                          let '(right_ty, ctxt) := function_parameter in
                          ((Script_typed_ir.Pair_t (left_ty, l_field, l_var)
                            (right_ty, r_field, r_var) tname has_big_map), ctxt))))))
    |
      (Script_typed_ir.Union_t (tal, tal_annot) (tar, tar_annot) tn1 has_big_map,
        Script_typed_ir.Union_t (tbl, tbl_annot) (tbr, tbr_annot) tn2 _) =>
      Error_monad.op_gtgtquestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname =>
          Error_monad.op_gtgtquestion
            (Script_ir_annot.merge_field_annot legacy tal_annot tbl_annot)
            (fun left_annot =>
              Error_monad.op_gtgtquestion
                (Script_ir_annot.merge_field_annot legacy tar_annot tbr_annot)
                (fun right_annot =>
                  Error_monad.op_gtgtquestion (help ctxt tal tbl)
                    (fun function_parameter =>
                      let '(left_ty, ctxt) := function_parameter in
                      Error_monad.op_gtpipequestion (help ctxt tar tbr)
                        (fun function_parameter =>
                          let '(right_ty, ctxt) := function_parameter in
                          ((Script_typed_ir.Union_t (left_ty, left_annot)
                            (right_ty, right_annot) tname has_big_map), ctxt))))))
    |
      (Script_typed_ir.Lambda_t tal tar tn1,
        Script_typed_ir.Lambda_t tbl tbr tn2) =>
      Error_monad.op_gtgtquestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname =>
          Error_monad.op_gtgtquestion (help ctxt tal tbl)
            (fun function_parameter =>
              let '(left_ty, ctxt) := function_parameter in
              Error_monad.op_gtpipequestion (help ctxt tar tbr)
                (fun function_parameter =>
                  let '(right_ty, ctxt) := function_parameter in
                  ((Script_typed_ir.Lambda_t left_ty right_ty tname), ctxt))))
    | (Script_typed_ir.Contract_t tal tn1, Script_typed_ir.Contract_t tbl tn2)
      =>
      Error_monad.op_gtgtquestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname =>
          Error_monad.op_gtpipequestion (help ctxt tal tbl)
            (fun function_parameter =>
              let '(arg_ty, ctxt) := function_parameter in
              ((Script_typed_ir.Contract_t arg_ty tname), ctxt)))
    |
      (Script_typed_ir.Option_t tva tn1 has_big_map,
        Script_typed_ir.Option_t tvb tn2 _) =>
      Error_monad.op_gtgtquestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname =>
          Error_monad.op_gtpipequestion (help ctxt tva tvb)
            (fun function_parameter =>
              let '(ty, ctxt) := function_parameter in
              ((Script_typed_ir.Option_t ty tname has_big_map), ctxt)))
    |
      (Script_typed_ir.List_t tva tn1 has_big_map,
        Script_typed_ir.List_t tvb tn2 _) =>
      Error_monad.op_gtgtquestion
        (Script_ir_annot.merge_type_annot legacy tn1 tn2)
        (fun tname =>
          Error_monad.op_gtpipequestion (help ctxt tva tvb)
            (fun function_parameter =>
              let '(ty, ctxt) := function_parameter in
              ((Script_typed_ir.List_t ty tname has_big_map), ctxt)))
    | (_, _) =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    end in
  fun ctxt =>
    fun loc =>
      fun ty1 =>
        fun ty2 =>
          record_inconsistent_type_annotations ctxt loc ty1 ty2
            (help ctxt ty1 ty2).

Definition merge_stacks {ta : Set}
  (legacy : bool) (loc : Alpha_context.Script.location)
  : Alpha_context.context -> Script_typed_ir.stack_ty ta ->
  Script_typed_ir.stack_ty ta ->
  Error_monad.tzresult (Script_typed_ir.stack_ty ta * Alpha_context.context) :=
  let fix help {a : Set}
    (ctxt : Alpha_context.context) (stack1 : Script_typed_ir.stack_ty a)
    (stack2 : Script_typed_ir.stack_ty a) {struct ctxt}
    : Error_monad.tzresult (Script_typed_ir.stack_ty a * Alpha_context.context) :=
    match (stack1, stack2) with
    | (Script_typed_ir.Empty_t, Script_typed_ir.Empty_t) =>
      Error_monad.ok (Script_typed_ir.Empty_t, ctxt)
    |
      (Script_typed_ir.Item_t ty1 rest1 annot1,
        Script_typed_ir.Item_t ty2 rest2 annot2) =>
      let annot := Script_ir_annot.merge_var_annot annot1 annot2 in
      Error_monad.op_gtgtquestion (merge_types legacy ctxt loc ty1 ty2)
        (fun function_parameter =>
          let '(ty, ctxt) := function_parameter in
          Error_monad.op_gtpipequestion (help ctxt rest1 rest2)
            (fun function_parameter =>
              let '(rest, ctxt) := function_parameter in
              ((Script_typed_ir.Item_t ty rest annot), ctxt)))
    end in
  help.

Definition has_big_map {t : Set} (function_parameter : Script_typed_ir.ty t)
  : bool :=
  match function_parameter with
  | Script_typed_ir.Unit_t _ => false
  | Script_typed_ir.Int_t _ => false
  | Script_typed_ir.Nat_t _ => false
  | Script_typed_ir.Signature_t _ => false
  | Script_typed_ir.String_t _ => false
  | Script_typed_ir.Bytes_t _ => false
  | Script_typed_ir.Mutez_t _ => false
  | Script_typed_ir.Key_hash_t _ => false
  | Script_typed_ir.Key_t _ => false
  | Script_typed_ir.Timestamp_t _ => false
  | Script_typed_ir.Address_t _ => false
  | Script_typed_ir.Bool_t _ => false
  | Script_typed_ir.Lambda_t _ _ _ => false
  | Script_typed_ir.Set_t _ _ => false
  | Script_typed_ir.Big_map_t _ _ _ => true
  | Script_typed_ir.Contract_t _ _ => false
  | Script_typed_ir.Operation_t _ => false
  | Script_typed_ir.Chain_id_t _ => false
  | Script_typed_ir.Pair_t _ _ _ has_big_map => has_big_map
  | Script_typed_ir.Union_t _ _ _ has_big_map => has_big_map
  | Script_typed_ir.Option_t _ _ has_big_map => has_big_map
  | Script_typed_ir.List_t _ _ has_big_map => has_big_map
  | Script_typed_ir.Map_t _ _ _ has_big_map => has_big_map
  end.

Module judgement.
  Module Failed.
    Record record {descr : Set} := {
      descr : descr }.
    Arguments record : clear implicits.
  End Failed.
  Definition Failed_skeleton := Failed.record.
End judgement.

Reserved Notation "'judgement.Failed".
Reserved Notation "'judgement".

Inductive judgement_gadt : Set :=
| Typed : forall {aft bef : Set},
  Script_typed_ir.descr bef aft -> judgement_gadt
| Failed : forall {aft bef : Set}, 'judgement.Failed aft bef -> judgement_gadt

where "'judgement" := (fun (_ : Set) => judgement_gadt)
and "'judgement.Failed" := (fun (t_aft t_bef : Set) =>
  judgement.Failed_skeleton
    ((Script_typed_ir.stack_ty t_aft -> Script_typed_ir.descr t_bef t_aft) *
      t_aft)).

Module ConstructorRecordNotations_judgement_gadt.
  Module judgement.
    Definition Failed := 'judgement.Failed.
  End judgement.
End ConstructorRecordNotations_judgement_gadt.
Import ConstructorRecordNotations_judgement_gadt.

Definition judgement := 'judgement.

Module branch.
  Record record {t f b : Set} := Build {
    branch :
      (Script_typed_ir.descr t r -> Script_typed_ir.descr f r ->
      Script_typed_ir.descr b r) * r }.
  Arguments record : clear implicits.
  Definition with_branch {t_t t_f t_b} branch (r : record t_t t_f t_b) :=
    Build t_t t_f t_b branch.
End branch.
Definition branch := branch.record.

Definition merge_branches {a b bef : Set}
  (legacy : bool) (ctxt : Alpha_context.context) (loc : Z) (btr : judgement a)
  (bfr : judgement b) (function_parameter : branch a b bef)
  : Lwt.t (Error_monad.tzresult (judgement bef * Alpha_context.context)) :=
  let '{| branch.branch := branch |} := function_parameter in
  match (btr, bfr) with
  |
    (Typed ({| Script_typed_ir.descr.aft := aftbt |} as dbt),
      Typed ({| Script_typed_ir.descr.aft := aftbf |} as dbf)) =>
    let unmatched_branches (function_parameter : unit)
      : Lwt.t (Error_monad.tzresult Error_monad.__error) :=
      let '_ := function_parameter in
      Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt aftbt)
        (fun function_parameter =>
          let '(aftbt, ctxt) := function_parameter in
          Error_monad.op_gtgtpipequestion (serialize_stack_for_error ctxt aftbf)
            (fun function_parameter =>
              let '(aftbf, _ctxt) := function_parameter in
              extensible_type_value)) in
    Error_monad.trace_eval unmatched_branches
      (Error_monad.op_gtgteqquestion
        (Lwt.__return (stack_ty_eq ctxt 1 aftbt aftbf))
        (fun function_parameter =>
          let '(Eq, ctxt) := function_parameter in
          Error_monad.op_gtgteqquestion
            (Lwt.__return (merge_stacks legacy loc ctxt aftbt aftbf))
            (fun function_parameter =>
              let '(merged_stack, ctxt) := function_parameter in
              Error_monad.__return
                ((Typed
                  (branch (Script_typed_ir.descr.with_aft merged_stack dbt)
                    (Script_typed_ir.descr.with_aft merged_stack dbf))), ctxt))))
  |
    (Failed {| judgement.Failed.descr := descrt |},
      Failed {| judgement.Failed.descr := descrf |}) =>
    let __descr_value {D : Set} (ret : Script_typed_ir.stack_ty D)
      : Script_typed_ir.descr bef D :=
      branch (descrt ret) (descrf ret) in
    Error_monad.__return
      ((Failed {| judgement.Failed.descr := __descr_value |}), ctxt)
  | (Typed dbt, Failed {| judgement.Failed.descr := descrf |}) =>
    Error_monad.__return
      ((Typed (branch dbt (descrf (Script_typed_ir.descr.aft dbt)))), ctxt)
  | (Failed {| judgement.Failed.descr := descrt |}, Typed dbf) =>
    Error_monad.__return
      ((Typed (branch (descrt (Script_typed_ir.descr.aft dbf)) dbf)), ctxt)
  end.

Fixpoint parse_comparable_ty
  (ctxt : Alpha_context.context) (ty : Alpha_context.Script.node) {struct ctxt}
  : Error_monad.tzresult (ex_comparable_ty * Alpha_context.context) :=
  Error_monad.op_gtgtquestion
    (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle)
    (fun ctxt =>
      Error_monad.op_gtgtquestion
        (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
        (fun ctxt =>
          match ty with
          | Micheline.Prim loc Alpha_context.Script.T_int [] annot =>
            Error_monad.op_gtpipequestion
              (Script_ir_annot.parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty (Script_typed_ir.Int_key tname)), ctxt))
          | Micheline.Prim loc Alpha_context.Script.T_nat [] annot =>
            Error_monad.op_gtpipequestion
              (Script_ir_annot.parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty (Script_typed_ir.Nat_key tname)), ctxt))
          | Micheline.Prim loc Alpha_context.Script.T_string [] annot =>
            Error_monad.op_gtpipequestion
              (Script_ir_annot.parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty (Script_typed_ir.String_key tname)), ctxt))
          | Micheline.Prim loc Alpha_context.Script.T_bytes [] annot =>
            Error_monad.op_gtpipequestion
              (Script_ir_annot.parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty (Script_typed_ir.Bytes_key tname)), ctxt))
          | Micheline.Prim loc Alpha_context.Script.T_mutez [] annot =>
            Error_monad.op_gtpipequestion
              (Script_ir_annot.parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty (Script_typed_ir.Mutez_key tname)), ctxt))
          | Micheline.Prim loc Alpha_context.Script.T_bool [] annot =>
            Error_monad.op_gtpipequestion
              (Script_ir_annot.parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty (Script_typed_ir.Bool_key tname)), ctxt))
          | Micheline.Prim loc Alpha_context.Script.T_key_hash [] annot =>
            Error_monad.op_gtpipequestion
              (Script_ir_annot.parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty (Script_typed_ir.Key_hash_key tname)), ctxt))
          | Micheline.Prim loc Alpha_context.Script.T_timestamp [] annot =>
            Error_monad.op_gtpipequestion
              (Script_ir_annot.parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty (Script_typed_ir.Timestamp_key tname)), ctxt))
          | Micheline.Prim loc Alpha_context.Script.T_address [] annot =>
            Error_monad.op_gtpipequestion
              (Script_ir_annot.parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty (Script_typed_ir.Address_key tname)), ctxt))
          |
            Micheline.Prim loc
              ((Alpha_context.Script.T_int | Alpha_context.Script.T_nat |
              Alpha_context.Script.T_string | Alpha_context.Script.T_mutez |
              Alpha_context.Script.T_bool | Alpha_context.Script.T_key |
              Alpha_context.Script.T_address | Alpha_context.Script.T_timestamp)
                as prim) l _ => Error_monad.__error_value extensible_type_value
          |
            Micheline.Prim loc
              (Alpha_context.Script.T_pair | Alpha_context.Script.T_or |
              Alpha_context.Script.T_set | Alpha_context.Script.T_map |
              Alpha_context.Script.T_list | Alpha_context.Script.T_option |
              Alpha_context.Script.T_lambda | Alpha_context.Script.T_unit |
              Alpha_context.Script.T_signature | Alpha_context.Script.T_contract)
              _ _ => Error_monad.__error_value extensible_type_value
          | expr =>
            Pervasives.op_atat Error_monad.__error_value
              (unexpected expr [] Script_tc_errors.Type_namespace
                [
                  Alpha_context.Script.T_int;
                  Alpha_context.Script.T_nat;
                  Alpha_context.Script.T_string;
                  Alpha_context.Script.T_mutez;
                  Alpha_context.Script.T_bool;
                  Alpha_context.Script.T_key;
                  Alpha_context.Script.T_key_hash;
                  Alpha_context.Script.T_timestamp
                ])
          end))

with parse_packable_ty (ctxt : Alpha_context.context) (legacy : bool)
  {struct ctxt}
  : Alpha_context.Script.node ->
  Error_monad.tzresult (ex_ty * Alpha_context.context) :=
  parse_ty ctxt legacy false false legacy

with parse_parameter_ty (ctxt : Alpha_context.context) (legacy : bool)
  {struct ctxt}
  : Alpha_context.Script.node ->
  Error_monad.tzresult (ex_ty * Alpha_context.context) :=
  parse_ty ctxt legacy true false true

with parse_any_ty (ctxt : Alpha_context.context) (legacy : bool) {struct ctxt}
  : Alpha_context.Script.node ->
  Error_monad.tzresult (ex_ty * Alpha_context.context) :=
  parse_ty ctxt legacy true true true

with parse_ty
  (ctxt : Alpha_context.context) (legacy : bool) (allow_big_map : bool)
  (allow_operation : bool) (allow_contract : bool)
  (node : Alpha_context.Script.node) {struct ctxt}
  : Error_monad.tzresult (ex_ty * Alpha_context.context) :=
  Error_monad.op_gtgtquestion
    (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle)
    (fun ctxt =>
      match
        (node,
          match node with
          | Micheline.Prim loc Alpha_context.Script.T_big_map args annot =>
            allow_big_map
          | _ => false
          end) with
      | (Micheline.Prim loc Alpha_context.Script.T_unit [] annot, _) =>
        Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Error_monad.op_gtpipequestion
              (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Script_typed_ir.Unit_t ty_name)), ctxt)))
      | (Micheline.Prim loc Alpha_context.Script.T_int [] annot, _) =>
        Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Error_monad.op_gtpipequestion
              (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Script_typed_ir.Int_t ty_name)), ctxt)))
      | (Micheline.Prim loc Alpha_context.Script.T_nat [] annot, _) =>
        Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Error_monad.op_gtpipequestion
              (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Script_typed_ir.Nat_t ty_name)), ctxt)))
      | (Micheline.Prim loc Alpha_context.Script.T_string [] annot, _) =>
        Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Error_monad.op_gtpipequestion
              (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Script_typed_ir.String_t ty_name)), ctxt)))
      | (Micheline.Prim loc Alpha_context.Script.T_bytes [] annot, _) =>
        Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Error_monad.op_gtpipequestion
              (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Script_typed_ir.Bytes_t ty_name)), ctxt)))
      | (Micheline.Prim loc Alpha_context.Script.T_mutez [] annot, _) =>
        Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Error_monad.op_gtpipequestion
              (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Script_typed_ir.Mutez_t ty_name)), ctxt)))
      | (Micheline.Prim loc Alpha_context.Script.T_bool [] annot, _) =>
        Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Error_monad.op_gtpipequestion
              (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Script_typed_ir.Bool_t ty_name)), ctxt)))
      | (Micheline.Prim loc Alpha_context.Script.T_key [] annot, _) =>
        Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Error_monad.op_gtpipequestion
              (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Script_typed_ir.Key_t ty_name)), ctxt)))
      | (Micheline.Prim loc Alpha_context.Script.T_key_hash [] annot, _) =>
        Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Error_monad.op_gtpipequestion
              (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Script_typed_ir.Key_hash_t ty_name)), ctxt)))
      | (Micheline.Prim loc Alpha_context.Script.T_timestamp [] annot, _) =>
        Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Error_monad.op_gtpipequestion
              (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Script_typed_ir.Timestamp_t ty_name)), ctxt)))
      | (Micheline.Prim loc Alpha_context.Script.T_address [] annot, _) =>
        Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Error_monad.op_gtpipequestion
              (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Script_typed_ir.Address_t ty_name)), ctxt)))
      | (Micheline.Prim loc Alpha_context.Script.T_signature [] annot, _) =>
        Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Error_monad.op_gtpipequestion
              (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Script_typed_ir.Signature_t ty_name)), ctxt)))
      | (Micheline.Prim loc Alpha_context.Script.T_operation [] annot, _) =>
        if allow_operation then
          Error_monad.op_gtgtquestion
            (Script_ir_annot.parse_type_annot loc annot)
            (fun ty_name =>
              Error_monad.op_gtpipequestion
                (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
                (fun ctxt =>
                  ((Ex_ty (Script_typed_ir.Operation_t ty_name)), ctxt)))
        else
          Error_monad.__error_value extensible_type_value
      | (Micheline.Prim loc Alpha_context.Script.T_chain_id [] annot, _) =>
        Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Error_monad.op_gtpipequestion
              (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Script_typed_ir.Chain_id_t ty_name)), ctxt)))
      |
        (Micheline.Prim loc Alpha_context.Script.T_contract (cons utl []) annot,
          _) =>
        if allow_contract then
          Error_monad.op_gtgtquestion (parse_parameter_ty ctxt legacy utl)
            (fun function_parameter =>
              let '(Ex_ty tl, ctxt) := function_parameter in
              Error_monad.op_gtgtquestion
                (Script_ir_annot.parse_type_annot loc annot)
                (fun ty_name =>
                  Error_monad.op_gtpipequestion
                    (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 1))
                    (fun ctxt =>
                      ((Ex_ty (Script_typed_ir.Contract_t tl ty_name)), ctxt))))
        else
          Error_monad.__error_value extensible_type_value
      |
        (Micheline.Prim loc Alpha_context.Script.T_pair (cons utl (cons utr []))
          annot, _) =>
        Error_monad.op_gtgtquestion (Script_ir_annot.extract_field_annot utl)
          (fun function_parameter =>
            let '(utl, left_field) := function_parameter in
            Error_monad.op_gtgtquestion
              (Script_ir_annot.extract_field_annot utr)
              (fun function_parameter =>
                let '(utr, right_field) := function_parameter in
                Error_monad.op_gtgtquestion
                  (parse_ty ctxt legacy allow_big_map allow_operation
                    allow_contract utl)
                  (fun function_parameter =>
                    let '(Ex_ty tl, ctxt) := function_parameter in
                    Error_monad.op_gtgtquestion
                      (parse_ty ctxt legacy allow_big_map allow_operation
                        allow_contract utr)
                      (fun function_parameter =>
                        let '(Ex_ty tr, ctxt) := function_parameter in
                        Error_monad.op_gtgtquestion
                          (Script_ir_annot.parse_type_annot loc annot)
                          (fun ty_name =>
                            Error_monad.op_gtpipequestion
                              (Alpha_context.Gas.consume ctxt
                                (Typecheck_costs.type_ 2))
                              (fun ctxt =>
                                ((Ex_ty
                                  (Script_typed_ir.Pair_t (tl, left_field, None)
                                    (tr, right_field, None) ty_name
                                    (Pervasives.op_pipepipe (has_big_map tl)
                                      (has_big_map tr)))), ctxt)))))))
      |
        (Micheline.Prim loc Alpha_context.Script.T_or (cons utl (cons utr []))
          annot, _) =>
        Error_monad.op_gtgtquestion (Script_ir_annot.extract_field_annot utl)
          (fun function_parameter =>
            let '(utl, left_constr) := function_parameter in
            Error_monad.op_gtgtquestion
              (Script_ir_annot.extract_field_annot utr)
              (fun function_parameter =>
                let '(utr, right_constr) := function_parameter in
                Error_monad.op_gtgtquestion
                  (parse_ty ctxt legacy allow_big_map allow_operation
                    allow_contract utl)
                  (fun function_parameter =>
                    let '(Ex_ty tl, ctxt) := function_parameter in
                    Error_monad.op_gtgtquestion
                      (parse_ty ctxt legacy allow_big_map allow_operation
                        allow_contract utr)
                      (fun function_parameter =>
                        let '(Ex_ty tr, ctxt) := function_parameter in
                        Error_monad.op_gtgtquestion
                          (Script_ir_annot.parse_type_annot loc annot)
                          (fun ty_name =>
                            Error_monad.op_gtpipequestion
                              (Alpha_context.Gas.consume ctxt
                                (Typecheck_costs.type_ 2))
                              (fun ctxt =>
                                ((Ex_ty
                                  (Script_typed_ir.Union_t (tl, left_constr)
                                    (tr, right_constr) ty_name
                                    (Pervasives.op_pipepipe (has_big_map tl)
                                      (has_big_map tr)))), ctxt)))))))
      |
        (Micheline.Prim loc Alpha_context.Script.T_lambda
          (cons uta (cons utr [])) annot, _) =>
        Error_monad.op_gtgtquestion (parse_any_ty ctxt legacy uta)
          (fun function_parameter =>
            let '(Ex_ty ta, ctxt) := function_parameter in
            Error_monad.op_gtgtquestion (parse_any_ty ctxt legacy utr)
              (fun function_parameter =>
                let '(Ex_ty tr, ctxt) := function_parameter in
                Error_monad.op_gtgtquestion
                  (Script_ir_annot.parse_type_annot loc annot)
                  (fun ty_name =>
                    Error_monad.op_gtpipequestion
                      (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 2))
                      (fun ctxt =>
                        ((Ex_ty (Script_typed_ir.Lambda_t ta tr ty_name)), ctxt)))))
      | (Micheline.Prim loc Alpha_context.Script.T_option (cons ut []) annot, _)
        =>
        Error_monad.op_gtgtquestion
          (if legacy then
            Error_monad.op_gtgtquestion (Script_ir_annot.extract_field_annot ut)
              (fun function_parameter =>
                let '(ut, _some_constr) := function_parameter in
                Error_monad.op_gtgtquestion
                  (Script_ir_annot.parse_composed_type_annot loc annot)
                  (fun function_parameter =>
                    let '(ty_name, _none_constr, _) := function_parameter in
                    Error_monad.ok (ut, ty_name)))
          else
            Error_monad.op_gtgtquestion
              (Script_ir_annot.parse_type_annot loc annot)
              (fun ty_name => Error_monad.ok (ut, ty_name)))
          (fun function_parameter =>
            let '(ut, ty_name) := function_parameter in
            Error_monad.op_gtgtquestion
              (parse_ty ctxt legacy allow_big_map allow_operation allow_contract
                ut)
              (fun function_parameter =>
                let '(Ex_ty __t_value, ctxt) := function_parameter in
                Error_monad.op_gtpipequestion
                  (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 2))
                  (fun ctxt =>
                    ((Ex_ty
                      (Script_typed_ir.Option_t __t_value ty_name
                        (has_big_map __t_value))), ctxt))))
      | (Micheline.Prim loc Alpha_context.Script.T_list (cons ut []) annot, _)
        =>
        Error_monad.op_gtgtquestion
          (parse_ty ctxt legacy allow_big_map allow_operation allow_contract ut)
          (fun function_parameter =>
            let '(Ex_ty __t_value, ctxt) := function_parameter in
            Error_monad.op_gtgtquestion
              (Script_ir_annot.parse_type_annot loc annot)
              (fun ty_name =>
                Error_monad.op_gtpipequestion
                  (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 1))
                  (fun ctxt =>
                    ((Ex_ty
                      (Script_typed_ir.List_t __t_value ty_name
                        (has_big_map __t_value))), ctxt))))
      | (Micheline.Prim loc Alpha_context.Script.T_set (cons ut []) annot, _) =>
        Error_monad.op_gtgtquestion (parse_comparable_ty ctxt ut)
          (fun function_parameter =>
            let '(Ex_comparable_ty __t_value, ctxt) := function_parameter in
            Error_monad.op_gtgtquestion
              (Script_ir_annot.parse_type_annot loc annot)
              (fun ty_name =>
                Error_monad.op_gtpipequestion
                  (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 1))
                  (fun ctxt =>
                    ((Ex_ty (Script_typed_ir.Set_t __t_value ty_name)), ctxt))))
      |
        (Micheline.Prim loc Alpha_context.Script.T_map (cons uta (cons utr []))
          annot, _) =>
        Error_monad.op_gtgtquestion (parse_comparable_ty ctxt uta)
          (fun function_parameter =>
            let '(Ex_comparable_ty ta, ctxt) := function_parameter in
            Error_monad.op_gtgtquestion
              (parse_ty ctxt legacy allow_big_map allow_operation allow_contract
                utr)
              (fun function_parameter =>
                let '(Ex_ty tr, ctxt) := function_parameter in
                Error_monad.op_gtgtquestion
                  (Script_ir_annot.parse_type_annot loc annot)
                  (fun ty_name =>
                    Error_monad.op_gtpipequestion
                      (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 2))
                      (fun ctxt =>
                        ((Ex_ty
                          (Script_typed_ir.Map_t ta tr ty_name (has_big_map tr))),
                          ctxt)))))
      | (Micheline.Prim loc Alpha_context.Script.T_big_map args annot, true) =>
        Error_monad.op_gtgtquestion
          (parse_big_map_ty ctxt legacy loc args annot)
          (fun function_parameter =>
            let '(big_map_ty, ctxt) := function_parameter in
            Error_monad.op_gtpipequestion
              (Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 2))
              (fun ctxt => (big_map_ty, ctxt)))
      | (Micheline.Prim loc Alpha_context.Script.T_big_map _ _, _) =>
        Error_monad.__error_value extensible_type_value
      |
        (Micheline.Prim loc
          ((Alpha_context.Script.T_unit | Alpha_context.Script.T_signature |
          Alpha_context.Script.T_int | Alpha_context.Script.T_nat |
          Alpha_context.Script.T_string | Alpha_context.Script.T_bytes |
          Alpha_context.Script.T_mutez | Alpha_context.Script.T_bool |
          Alpha_context.Script.T_key | Alpha_context.Script.T_key_hash |
          Alpha_context.Script.T_timestamp | Alpha_context.Script.T_address) as
            prim) l _, _) => Error_monad.__error_value extensible_type_value
      |
        (Micheline.Prim loc
          ((Alpha_context.Script.T_set | Alpha_context.Script.T_list |
          Alpha_context.Script.T_option | Alpha_context.Script.T_contract) as
            prim) l _, _) => Error_monad.__error_value extensible_type_value
      |
        (Micheline.Prim loc
          ((Alpha_context.Script.T_pair | Alpha_context.Script.T_or |
          Alpha_context.Script.T_map | Alpha_context.Script.T_lambda) as prim) l
          _, _) => Error_monad.__error_value extensible_type_value
      | (expr, _) =>
        Pervasives.op_atat Error_monad.__error_value
          (unexpected expr [] Script_tc_errors.Type_namespace
            [
              Alpha_context.Script.T_pair;
              Alpha_context.Script.T_or;
              Alpha_context.Script.T_set;
              Alpha_context.Script.T_map;
              Alpha_context.Script.T_list;
              Alpha_context.Script.T_option;
              Alpha_context.Script.T_lambda;
              Alpha_context.Script.T_unit;
              Alpha_context.Script.T_signature;
              Alpha_context.Script.T_contract;
              Alpha_context.Script.T_int;
              Alpha_context.Script.T_nat;
              Alpha_context.Script.T_operation;
              Alpha_context.Script.T_string;
              Alpha_context.Script.T_bytes;
              Alpha_context.Script.T_mutez;
              Alpha_context.Script.T_bool;
              Alpha_context.Script.T_key;
              Alpha_context.Script.T_key_hash;
              Alpha_context.Script.T_timestamp;
              Alpha_context.Script.T_chain_id
            ])
      end)

with parse_big_map_ty
  (ctxt : Alpha_context.context) (legacy : bool)
  (big_map_loc : Alpha_context.Script.location)
  (args :
    list
      (Micheline.node Alpha_context.Script.location Alpha_context.Script.prim))
  (map_annot : Micheline.annot) {struct ctxt}
  : Error_monad.tzresult (ex_ty * Alpha_context.context) :=
  Error_monad.op_gtgtquestion
    (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle)
    (fun ctxt =>
      match args with
      | cons key_ty (cons value_ty []) =>
        Error_monad.op_gtgtquestion (parse_comparable_ty ctxt key_ty)
          (fun function_parameter =>
            let '(Ex_comparable_ty key_ty, ctxt) := function_parameter in
            Error_monad.op_gtgtquestion (parse_packable_ty ctxt legacy value_ty)
              (fun function_parameter =>
                let '(Ex_ty value_ty, ctxt) := function_parameter in
                Error_monad.op_gtpipequestion
                  (Script_ir_annot.parse_type_annot big_map_loc map_annot)
                  (fun map_name =>
                    let big_map_ty :=
                      Script_typed_ir.Big_map_t key_ty value_ty map_name in
                    ((Ex_ty big_map_ty), ctxt))))
      | args =>
        Pervasives.op_atat Error_monad.__error_value extensible_type_value
      end)

with parse_storage_ty
  (ctxt : Alpha_context.context) (legacy : bool)
  (node : Alpha_context.Script.node) {struct ctxt}
  : Error_monad.tzresult (ex_ty * Alpha_context.context) :=
  match
    (node,
      match node with
      |
        Micheline.Prim loc Alpha_context.Script.T_pair
          (cons
            (Micheline.Prim big_map_loc Alpha_context.Script.T_big_map args
              map_annot) (cons remaining_storage [])) storage_annot => legacy
      | _ => false
      end) with
  |
    (Micheline.Prim loc Alpha_context.Script.T_pair
      (cons
        (Micheline.Prim big_map_loc Alpha_context.Script.T_big_map args
          map_annot) (cons remaining_storage [])) storage_annot, true) =>
    match
      (storage_annot,
        match storage_annot with
        | cons single [] =>
          Pervasives.op_andand
            ((|Compare.Int|).(Compare.S.op_gt) (String.length single) 0)
            ((|Compare.Char|).(Compare.S.op_eq) (String.get single 0) "%" % char)
        | _ => false
        end) with
    | ([], _) => parse_ty ctxt legacy true false legacy node
    | (cons single [], true) => parse_ty ctxt legacy true false legacy node
    | (_, _) =>
      Error_monad.op_gtgtquestion
        (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle)
        (fun ctxt =>
          Error_monad.op_gtgtquestion
            (parse_big_map_ty ctxt legacy big_map_loc args map_annot)
            (fun function_parameter =>
              let '(Ex_ty big_map_ty, ctxt) := function_parameter in
              Error_monad.op_gtgtquestion
                (parse_ty ctxt legacy true false legacy remaining_storage)
                (fun function_parameter =>
                  let '(Ex_ty remaining_storage, ctxt) := function_parameter in
                  Error_monad.op_gtgtquestion
                    (Script_ir_annot.parse_composed_type_annot loc storage_annot)
                    (fun function_parameter =>
                      let '(ty_name, map_field, storage_field) :=
                        function_parameter in
                      Error_monad.op_gtpipequestion
                        (Alpha_context.Gas.consume ctxt
                          (Typecheck_costs.type_ 5))
                        (fun ctxt =>
                          ((Ex_ty
                            (Script_typed_ir.Pair_t
                              (big_map_ty, map_field, None)
                              (remaining_storage, storage_field, None) ty_name
                              true)), ctxt))))))
    end
  | (_, _) => parse_ty ctxt legacy true false legacy node
  end.

Definition check_packable {A : Set}
  (legacy : bool) (loc : Alpha_context.Script.location)
  (root : Script_typed_ir.ty A) : Error_monad.tzresult unit :=
  let fix check {t : Set} (function_parameter : Script_typed_ir.ty t)
    {struct function_parameter} : Error_monad.tzresult unit :=
    match
      (function_parameter,
        match function_parameter with
        | Script_typed_ir.Contract_t _ _ => legacy
        | _ => false
        end) with
    | (Script_typed_ir.Big_map_t _ _ _, _) =>
      Error_monad.__error_value extensible_type_value
    | (Script_typed_ir.Operation_t _, _) =>
      Error_monad.__error_value extensible_type_value
    | (Script_typed_ir.Unit_t _, _) => Error_monad.ok tt
    | (Script_typed_ir.Int_t _, _) => Error_monad.ok tt
    | (Script_typed_ir.Nat_t _, _) => Error_monad.ok tt
    | (Script_typed_ir.Signature_t _, _) => Error_monad.ok tt
    | (Script_typed_ir.String_t _, _) => Error_monad.ok tt
    | (Script_typed_ir.Bytes_t _, _) => Error_monad.ok tt
    | (Script_typed_ir.Mutez_t _, _) => Error_monad.ok tt
    | (Script_typed_ir.Key_hash_t _, _) => Error_monad.ok tt
    | (Script_typed_ir.Key_t _, _) => Error_monad.ok tt
    | (Script_typed_ir.Timestamp_t _, _) => Error_monad.ok tt
    | (Script_typed_ir.Address_t _, _) => Error_monad.ok tt
    | (Script_typed_ir.Bool_t _, _) => Error_monad.ok tt
    | (Script_typed_ir.Chain_id_t _, _) => Error_monad.ok tt
    | (Script_typed_ir.Pair_t (l_ty, _, _) (r_ty, _, _) _ _, _) =>
      Error_monad.op_gtgtquestion (check l_ty)
        (fun function_parameter =>
          let '_ := function_parameter in
          check r_ty)
    | (Script_typed_ir.Union_t (l_ty, _) (r_ty, _) _ _, _) =>
      Error_monad.op_gtgtquestion (check l_ty)
        (fun function_parameter =>
          let '_ := function_parameter in
          check r_ty)
    | (Script_typed_ir.Option_t v_ty _ _, _) => check v_ty
    | (Script_typed_ir.List_t elt_ty _ _, _) => check elt_ty
    | (Script_typed_ir.Set_t _ _, _) => Error_monad.ok tt
    | (Script_typed_ir.Map_t _ elt_ty _ _, _) => check elt_ty
    | (Script_typed_ir.Lambda_t _l_ty _r_ty _, _) => Error_monad.ok tt
    | (Script_typed_ir.Contract_t _ _, true) => Error_monad.ok tt
    | (Script_typed_ir.Contract_t _ _, _) =>
      Error_monad.__error_value extensible_type_value
    end in
  check root.

Reserved Notation "'ex_script".

Inductive ex_script_gadt : Set :=
| Ex_script : forall {a c : Set}, Script_typed_ir.script a c -> ex_script_gadt

where "'ex_script" := (ex_script_gadt).

Definition ex_script := 'ex_script.

Reserved Notation "'dig_proof_argument".

Inductive dig_proof_argument_gadt : Set :=
| Dig_proof_argument : forall {aft bef rest x : Set},
  Script_typed_ir.stack_prefix_preservation_witness (x * rest) rest bef aft *
    (Script_typed_ir.ty x * option Script_typed_ir.var_annot) *
    Script_typed_ir.stack_ty aft -> dig_proof_argument_gadt

where "'dig_proof_argument" := (fun (_ : Set) => dig_proof_argument_gadt).

Definition dig_proof_argument := 'dig_proof_argument.

Reserved Notation "'dug_proof_argument".

Inductive dug_proof_argument_gadt : Set :=
| Dug_proof_argument : forall {aft bef rest x : Set},
  Script_typed_ir.stack_prefix_preservation_witness rest (x * rest) bef aft *
    unit * Script_typed_ir.stack_ty aft -> dug_proof_argument_gadt

where "'dug_proof_argument" := (fun (_ _ : Set) => dug_proof_argument_gadt).

Definition dug_proof_argument := 'dug_proof_argument.

Reserved Notation "'dipn_proof_argument".

Inductive dipn_proof_argument_gadt : Set :=
| Dipn_proof_argument : forall {aft bef faft fbef : Set},
  Script_typed_ir.stack_prefix_preservation_witness fbef faft bef aft *
    (Alpha_context.context * Script_typed_ir.descr fbef faft) *
    Script_typed_ir.stack_ty aft -> dipn_proof_argument_gadt

where "'dipn_proof_argument" := (fun (_ : Set) => dipn_proof_argument_gadt).

Definition dipn_proof_argument := 'dipn_proof_argument.

Reserved Notation "'dropn_proof_argument".

Inductive dropn_proof_argument_gadt : Set :=
| Dropn_proof_argument : forall {aft bef rest : Set},
  Script_typed_ir.stack_prefix_preservation_witness rest rest bef aft *
    Script_typed_ir.stack_ty rest * Script_typed_ir.stack_ty aft ->
  dropn_proof_argument_gadt

where "'dropn_proof_argument" := (fun (_ : Set) => dropn_proof_argument_gadt).

Definition dropn_proof_argument := 'dropn_proof_argument.

Definition parse_var_annot
  (loc : Z) (default : option (option Script_typed_ir.var_annot))
  (annot : list string)
  : Lwt.t (Error_monad.tzresult (option Script_typed_ir.var_annot)) :=
  Lwt.__return (Script_ir_annot.parse_var_annot loc default annot).

Definition parse_entrypoint_annot
  (loc : Z) (default : option (option Script_typed_ir.var_annot))
  (annot : list string)
  : Lwt.t
    (Error_monad.tzresult
      (option Script_typed_ir.var_annot * option Script_typed_ir.field_annot)) :=
  Lwt.__return (Script_ir_annot.parse_entrypoint_annot loc default annot).

Definition parse_constr_annot
  (loc : Z) (if_special_first : option (option Script_typed_ir.field_annot))
  (if_special_second : option (option Script_typed_ir.field_annot))
  (annot : list string)
  : Lwt.t
    (Error_monad.tzresult
      (option Script_typed_ir.var_annot * option Script_typed_ir.type_annot *
        option Script_typed_ir.field_annot * option Script_typed_ir.field_annot)) :=
  Lwt.__return
    (Script_ir_annot.parse_constr_annot loc if_special_first if_special_second
      annot).

Definition parse_two_var_annot (loc : Z) (annot : list string)
  : Lwt.t
    (Error_monad.tzresult
      (option Script_typed_ir.var_annot * option Script_typed_ir.var_annot)) :=
  Lwt.__return (Script_ir_annot.parse_two_var_annot loc annot).

Definition parse_destr_annot
  (loc : Z) (annot : list string)
  (default_accessor : option Script_typed_ir.field_annot)
  (field_name : option Script_typed_ir.field_annot)
  (pair_annot : option Script_typed_ir.var_annot)
  (value_annot : option Script_typed_ir.var_annot)
  : Lwt.t
    (Error_monad.tzresult
      (option Script_typed_ir.var_annot * option Script_typed_ir.field_annot)) :=
  Lwt.__return
    (Script_ir_annot.parse_destr_annot loc annot default_accessor field_name
      pair_annot value_annot).

Definition parse_var_type_annot (loc : Z) (annot : list string)
  : Lwt.t
    (Error_monad.tzresult
      (option Script_typed_ir.var_annot * option Script_typed_ir.type_annot)) :=
  Lwt.__return (Script_ir_annot.parse_var_type_annot loc annot).

Definition find_entrypoint {A : Set}
  (full : Script_typed_ir.ty A)
  (root_name : option (|Compare.String|).(Compare.S.t))
  (entrypoint : (|Compare.String|).(Compare.S.t))
  : Error_monad.tzresult
    ((Alpha_context.Script.node -> Alpha_context.Script.node) * ex_ty) :=
  let fix find_entrypoint {t : Set}
    (__t_value : Script_typed_ir.ty t) (entrypoint : string) {struct __t_value}
    : (Alpha_context.Script.node -> Alpha_context.Script.node) * ex_ty :=
    match __t_value with
    | Script_typed_ir.Union_t (tl, al) (tr, ar) _ _ =>
      if
        match al with
        | None => false
        | Some (Field_annot l) =>
          (|Compare.String|).(Compare.S.op_eq) l entrypoint
        end then
        ((fun e => Micheline.Prim 0 Alpha_context.Script.D_Left [ e ] []),
          (Ex_ty tl))
      else
        if
          match ar with
          | None => false
          | Some (Field_annot r) =>
            (|Compare.String|).(Compare.S.op_eq) r entrypoint
          end then
          ((fun e => Micheline.Prim 0 Alpha_context.Script.D_Right [ e ] []),
            (Ex_ty tr))
        else
          (* ❌ Try-with are not handled *)
          try
            (let '(f, __t_value) := find_entrypoint tl entrypoint in
            ((fun e => Micheline.Prim 0 Alpha_context.Script.D_Left [ f e ] []),
              __t_value))
    | _ => Pervasives.raise extensible_type_value
    end in
  let entrypoint :=
    if (|Compare.String|).(Compare.S.op_eq) entrypoint "" then
      "default"
    else
      entrypoint in
  if (|Compare.Int|).(Compare.S.op_gt) (String.length entrypoint) 31 then
    Error_monad.__error_value extensible_type_value
  else
    match
      (root_name,
        match root_name with
        | Some root_name =>
          (|Compare.String|).(Compare.S.op_eq) entrypoint root_name
        | _ => false
        end) with
    | (Some root_name, true) => Error_monad.ok ((fun e => e), (Ex_ty full))
    | (_, _) =>
      (* ❌ Try-with are not handled *)
      try (Error_monad.ok (find_entrypoint full entrypoint))
    end.

Definition find_entrypoint_for_type {A B : Set}
  (full : Script_typed_ir.ty A) (expected : Script_typed_ir.ty B)
  (root_name : option (|Compare.String|).(Compare.S.t))
  (entrypoint : (|Compare.String|).(Compare.S.t)) (ctxt : Alpha_context.context)
  : Error_monad.tzresult (Alpha_context.context * string * Script_typed_ir.ty B) :=
  match (entrypoint, root_name) with
  | ("default", Some "root") =>
    match find_entrypoint full root_name entrypoint with
    | (Pervasives.Error _) as err => err
    | Pervasives.Ok (_, Ex_ty ty) =>
      match ty_eq ctxt expected ty with
      | Pervasives.Ok (Eq, ctxt) => Error_monad.ok (ctxt, "default", ty)
      | Pervasives.Error _ =>
        Error_monad.op_gtgtquestion (ty_eq ctxt expected full)
          (fun function_parameter =>
            let '(Eq, ctxt) := function_parameter in
            Error_monad.ok (ctxt, "root", full))
      end
    end
  | _ =>
    Error_monad.op_gtgtquestion (find_entrypoint full root_name entrypoint)
      (fun function_parameter =>
        let '(_, Ex_ty ty) := function_parameter in
        Error_monad.op_gtgtquestion (ty_eq ctxt expected ty)
          (fun function_parameter =>
            let '(Eq, ctxt) := function_parameter in
            Error_monad.ok (ctxt, entrypoint, ty)))
  end.

Definition Entrypoints :=
  __Set.Make
    (existT _ _
      {|
        Compare.COMPARABLE.compare := String.compare
      |}).

(* ❌ The definition of exceptions is not handled. *)
(* exception Duplicate *)

(* ❌ The definition of exceptions is not handled. *)
(* exception Too_long *)

Definition well_formed_entrypoints {A : Set}
  (full : Script_typed_ir.ty A) (root_name : option (|Entrypoints|).(S.SET.elt))
  : Error_monad.tzresult unit :=
  let merge {B C : Set}
    (path : list B)
    (annot : option (* `Field_annot *) (|Entrypoints|).(S.SET.elt))
    (ty : Script_typed_ir.ty C) (reachable : bool)
    (function_parameter : option (list B) * (|Entrypoints|).(S.SET.t))
    : option (list B) * (|Entrypoints|).(S.SET.t) :=
    let '(first_unreachable, all) as acc := function_parameter in
    match annot with
    | None | Some (Field_annot "") =>
      if reachable then
        acc
      else
        match ty with
        | Script_typed_ir.Union_t _ _ _ _ => acc
        | _ =>
          match first_unreachable with
          | None => ((Some (List.rev path)), all)
          | Some _ => acc
          end
        end
    | Some (Field_annot name) =>
      if (|Compare.Int|).(Compare.S.op_gt) (String.length name) 31 then
        Pervasives.raise extensible_type_value
      else
        if (|Entrypoints|).(S.SET.mem) name all then
          Pervasives.raise extensible_type_value
        else
          (first_unreachable, ((|Entrypoints|).(S.SET.add) name all))
    end in
  let fix check {t : Set}
    (__t_value : Script_typed_ir.ty t) (path : list Alpha_context.Script.prim)
    (reachable : bool)
    (acc : option (list Alpha_context.Script.prim) * (|Entrypoints|).(S.SET.t))
    {struct __t_value}
    : option (list Alpha_context.Script.prim) * (|Entrypoints|).(S.SET.t) :=
    match __t_value with
    | Script_typed_ir.Union_t (tl, al) (tr, ar) _ _ =>
      let acc :=
        merge (cons Alpha_context.Script.D_Left path) al tl reachable acc in
      let acc :=
        merge (cons Alpha_context.Script.D_Right path) ar tr reachable acc in
      let acc :=
        check tl (cons Alpha_context.Script.D_Left path)
          match al with
          | Some _ => true
          | None => reachable
          end acc in
      check tr (cons Alpha_context.Script.D_Right path)
        match ar with
        | Some _ => true
        | None => reachable
        end acc
    | _ => acc
    end in
  (* ❌ Try-with are not handled *)
  try
    (let '(init, reachable) :=
      match root_name with
      | None | Some "" => ((|Entrypoints|).(S.SET.empty), false)
      | Some name => (((|Entrypoints|).(S.SET.singleton) name), true)
      end in
    let '(first_unreachable, all) := check full [] reachable (None, init) in
    if Pervasives.not ((|Entrypoints|).(S.SET.mem) "default" all) then
      Error_monad.ok tt
    else
      match first_unreachable with
      | None => Error_monad.ok tt
      | Some path => Error_monad.__error_value extensible_type_value
      end).

Fixpoint parse_data {a : Set}
  (type_logger : option type_logger) (ctxt : Alpha_context.context)
  (legacy : bool) (ty : Script_typed_ir.ty a)
  (script_data : Alpha_context.Script.node) {struct type_logger}
  : Lwt.t (Error_monad.tzresult (a * Alpha_context.context)) :=
  Error_monad.op_gtgteqquestion
    (Lwt.__return (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
    (fun ctxt =>
      let __error_value (function_parameter : unit)
        : Lwt.t (Error_monad.tzresult Error_monad.__error) :=
        let '_ := function_parameter in
        Error_monad.op_gtgtpipequestion
          (Lwt.__return (serialize_ty_for_error ctxt ty))
          (fun function_parameter =>
            let '(ty, _ctxt) := function_parameter in
            extensible_type_value) in
      let traced {B : Set} (body : Lwt.t (Error_monad.tzresult B))
        : Lwt.t (Error_monad.tzresult B) :=
        Error_monad.trace_eval __error_value body in
      let parse_items {B C D E : Set}
        (type_logger : option type_logger) (loc : Alpha_context.Script.location)
        (ctxt : Alpha_context.context)
        (expr : Micheline.node B Alpha_context.Script.prim)
        (key_type : Script_typed_ir.comparable_ty C)
        (value_type : Script_typed_ir.ty D)
        (items :
          list
            (Micheline.node Alpha_context.Script.location
              Alpha_context.Script.prim)) (item_wrapper : D -> E)
        : Lwt.t
          (Error_monad.tzresult
            (Script_typed_ir.map C E * Alpha_context.context)) :=
        let length := List.length items in
        Error_monad.op_gtgtpipequestion
          (Pervasives.op_pipegt
            (Error_monad.fold_left_s
              (fun function_parameter =>
                let '(last_value, map, ctxt) := function_parameter in
                fun item =>
                  Error_monad.op_gtgteqquestion
                    (Lwt.__return
                      (Alpha_context.Gas.consume ctxt
                        (Typecheck_costs.map_element length)))
                    (fun ctxt =>
                      match item with
                      |
                        Micheline.Prim _ Alpha_context.Script.D_Elt
                          (cons k (cons v [])) _ =>
                        Error_monad.op_gtgteqquestion
                          (parse_comparable_data type_logger ctxt key_type k)
                          (fun function_parameter =>
                            let '(k, ctxt) := function_parameter in
                            Error_monad.op_gtgteqquestion
                              (parse_data type_logger ctxt legacy value_type v)
                              (fun function_parameter =>
                                let '(v, ctxt) := function_parameter in
                                Error_monad.op_gtgteqquestion
                                  match last_value with
                                  | Some value =>
                                    if
                                      (|Compare.Int|).(Compare.S.op_lteq) 0
                                        (compare_comparable key_type value k)
                                      then
                                      if
                                        (|Compare.Int|).(Compare.S.op_eq) 0
                                          (compare_comparable key_type value k)
                                        then
                                        Error_monad.fail extensible_type_value
                                      else
                                        Error_monad.fail extensible_type_value
                                    else
                                      Error_monad.return_unit
                                  | None => Error_monad.return_unit
                                  end
                                  (fun function_parameter =>
                                    let '_ := function_parameter in
                                    Error_monad.__return
                                      ((Some k),
                                        (map_update k (Some (item_wrapper v))
                                          map), ctxt))))
                      | Micheline.Prim loc Alpha_context.Script.D_Elt l _ =>
                        Pervasives.op_atat Error_monad.fail
                          extensible_type_value
                      | Micheline.Prim loc name _ _ =>
                        Pervasives.op_atat Error_monad.fail
                          extensible_type_value
                      |
                        Micheline.Int _ _ | Micheline.String _ _ |
                        Micheline.Bytes _ _ | Micheline.Seq _ _ =>
                        Error_monad.op_gtgteqquestion (__error_value tt)
                          Error_monad.fail
                      end)) (None, (empty_map key_type), ctxt) items) traced)
          (fun function_parameter =>
            let '(_, items, ctxt) := function_parameter in
            (items, ctxt)) in
      match (ty, script_data) with
      |
        (Script_typed_ir.Unit_t _,
          Micheline.Prim loc Alpha_context.Script.D_Unit [] annot) =>
        Error_monad.op_gtgteqquestion
          (if legacy then
            Error_monad.__return tt
          else
            Script_ir_annot.fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgtpipequestion
              (Lwt.__return
                (Alpha_context.Gas.consume ctxt Typecheck_costs.__unit_value))
              (fun ctxt => (tt, ctxt)))
      |
        (Script_typed_ir.Unit_t _,
          Micheline.Prim loc Alpha_context.Script.D_Unit l _) =>
        traced (Error_monad.fail extensible_type_value)
      | (Script_typed_ir.Unit_t _, expr) =>
        traced
          (Error_monad.fail
            (unexpected expr [] Script_tc_errors.Constant_namespace
              [ Alpha_context.Script.D_Unit ]))
      |
        (Script_typed_ir.Bool_t _,
          Micheline.Prim loc Alpha_context.Script.D_True [] annot) =>
        Error_monad.op_gtgteqquestion
          (if legacy then
            Error_monad.__return tt
          else
            Script_ir_annot.fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgtpipequestion
              (Lwt.__return
                (Alpha_context.Gas.consume ctxt Typecheck_costs.__bool_value))
              (fun ctxt => (true, ctxt)))
      |
        (Script_typed_ir.Bool_t _,
          Micheline.Prim loc Alpha_context.Script.D_False [] annot) =>
        Error_monad.op_gtgteqquestion
          (if legacy then
            Error_monad.__return tt
          else
            Script_ir_annot.fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgtpipequestion
              (Lwt.__return
                (Alpha_context.Gas.consume ctxt Typecheck_costs.__bool_value))
              (fun ctxt => (false, ctxt)))
      |
        (Script_typed_ir.Bool_t _,
          Micheline.Prim loc
            ((Alpha_context.Script.D_True | Alpha_context.Script.D_False) as c)
            l _) => traced (Error_monad.fail extensible_type_value)
      | (Script_typed_ir.Bool_t _, expr) =>
        traced
          (Error_monad.fail
            (unexpected expr [] Script_tc_errors.Constant_namespace
              [ Alpha_context.Script.D_True; Alpha_context.Script.D_False ]))
      | (Script_typed_ir.String_t _, Micheline.String _ v) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt
              (Typecheck_costs.__string_value (String.length v))))
          (fun ctxt =>
            let fix check_printable_ascii (i : (|Compare.Int|).(Compare.S.t))
              {struct i} : bool :=
              if (|Compare.Int|).(Compare.S.op_lt) i 0 then
                true
              else
                match String.get v i with
                |
                  "010" % char | " " % char | "!" % char | """" % char |
                  "#" % char | "$" % char | "%" % char | "&" % char | "'" % char
                  | "(" % char | ")" % char | "*" % char | "+" % char |
                  "," % char | "-" % char | "." % char | "/" % char | "0" % char
                  | "1" % char | "2" % char | "3" % char | "4" % char |
                  "5" % char | "6" % char | "7" % char | "8" % char | "9" % char
                  | ":" % char | ";" % char | "<" % char | "=" % char |
                  ">" % char | "?" % char | "@" % char | "A" % char | "B" % char
                  | "C" % char | "D" % char | "E" % char | "F" % char |
                  "G" % char | "H" % char | "I" % char | "J" % char | "K" % char
                  | "L" % char | "M" % char | "N" % char | "O" % char |
                  "P" % char | "Q" % char | "R" % char | "S" % char | "T" % char
                  | "U" % char | "V" % char | "W" % char | "X" % char |
                  "Y" % char | "Z" % char | "[" % char | "\" % char | "]" % char
                  | "^" % char | "_" % char | "`" % char | "a" % char |
                  "b" % char | "c" % char | "d" % char | "e" % char | "f" % char
                  | "g" % char | "h" % char | "i" % char | "j" % char |
                  "k" % char | "l" % char | "m" % char | "n" % char | "o" % char
                  | "p" % char | "q" % char | "r" % char | "s" % char |
                  "t" % char | "u" % char | "v" % char | "w" % char | "x" % char
                  | "y" % char | "z" % char | "{" % char | "|" % char |
                  "}" % char | "~" % char =>
                  check_printable_ascii (Pervasives.op_minus i 1)
                | _ => false
                end in
            if check_printable_ascii (Pervasives.op_minus (String.length v) 1)
              then
              Error_monad.__return (v, ctxt)
            else
              Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail)
      | (Script_typed_ir.String_t _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      | (Script_typed_ir.Bytes_t _, Micheline.Bytes _ v) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt
              (Typecheck_costs.__string_value (MBytes.length v))))
          (fun ctxt => Error_monad.__return (v, ctxt))
      | (Script_typed_ir.Bytes_t _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      | (Script_typed_ir.Int_t _, Micheline.Int _ v) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt (Typecheck_costs.z v)))
          (fun ctxt =>
            Error_monad.__return ((Alpha_context.Script_int.of_zint v), ctxt))
      | (Script_typed_ir.Nat_t _, Micheline.Int _ v) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt (Typecheck_costs.z v)))
          (fun ctxt =>
            let v := Alpha_context.Script_int.of_zint v in
            if
              (|Compare.Int|).(Compare.S.op_gteq)
                (Alpha_context.Script_int.compare v
                  Alpha_context.Script_int.zero) 0 then
              Error_monad.__return ((Alpha_context.Script_int.abs v), ctxt)
            else
              Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail)
      | (Script_typed_ir.Int_t _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      | (Script_typed_ir.Nat_t _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      | (Script_typed_ir.Mutez_t _, Micheline.Int _ v) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Error_monad.op_gtgtquestion
              (Alpha_context.Gas.consume ctxt Typecheck_costs.tez)
              (fun ctxt =>
                Alpha_context.Gas.consume ctxt
                  Michelson_v1_gas.Cost_of.Legacy.z_to_int64)))
          (fun ctxt =>
            (* ❌ Try-with are not handled *)
            try
              match Alpha_context.Tez.of_mutez (Z.to_int64 v) with
              | None => Pervasives.raise extensible_type_value
              | Some tez => Error_monad.__return (tez, ctxt)
              end)
      | (Script_typed_ir.Mutez_t _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      | (Script_typed_ir.Timestamp_t _, Micheline.Int _ v) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt (Typecheck_costs.z v)))
          (fun ctxt =>
            Error_monad.__return
              ((Alpha_context.Script_timestamp.of_zint v), ctxt))
      | (Script_typed_ir.Timestamp_t _, Micheline.String _ s) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt Typecheck_costs.string_timestamp))
          (fun ctxt =>
            match Alpha_context.Script_timestamp.of_string s with
            | Some v => Error_monad.__return (v, ctxt)
            | None =>
              Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
            end)
      | (Script_typed_ir.Timestamp_t _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      | (Script_typed_ir.Key_t _, Micheline.Bytes _ __bytes_value) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt Typecheck_costs.key))
          (fun ctxt =>
            match
              Data_encoding.Binary.of_bytes
                (|Signature.Public_key|).(S.SPublic_key.encoding) __bytes_value
              with
            | Some k => Error_monad.__return (k, ctxt)
            | None =>
              Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
            end)
      | (Script_typed_ir.Key_t _, Micheline.String _ s) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt Typecheck_costs.key))
          (fun ctxt =>
            match (|Signature.Public_key|).(S.SPublic_key.of_b58check_opt) s
              with
            | Some k => Error_monad.__return (k, ctxt)
            | None =>
              Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
            end)
      | (Script_typed_ir.Key_t _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      | (Script_typed_ir.Key_hash_t _, Micheline.Bytes _ __bytes_value) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt Typecheck_costs.key_hash))
          (fun ctxt =>
            match
              Data_encoding.Binary.of_bytes
                (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding)
                __bytes_value with
            | Some k => Error_monad.__return (k, ctxt)
            | None =>
              Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
            end)
      | (Script_typed_ir.Key_hash_t _, Micheline.String _ s) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt Typecheck_costs.key_hash))
          (fun ctxt =>
            match
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.of_b58check_opt)
                s with
            | Some k => Error_monad.__return (k, ctxt)
            | None =>
              Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
            end)
      | (Script_typed_ir.Key_hash_t _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      | (Script_typed_ir.Signature_t _, Micheline.Bytes _ __bytes_value) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt Typecheck_costs.signature))
          (fun ctxt =>
            match Data_encoding.Binary.of_bytes Signature.encoding __bytes_value
              with
            | Some k => Error_monad.__return (k, ctxt)
            | None =>
              Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
            end)
      | (Script_typed_ir.Signature_t _, Micheline.String _ s) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt Typecheck_costs.signature))
          (fun ctxt =>
            match Signature.of_b58check_opt s with
            | Some s => Error_monad.__return (s, ctxt)
            | None =>
              Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
            end)
      | (Script_typed_ir.Signature_t _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      | (Script_typed_ir.Operation_t _, _) =>
        (* ❌ Assert instruction is not handled. *)
        assert false
      | (Script_typed_ir.Chain_id_t _, Micheline.Bytes _ __bytes_value) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt Typecheck_costs.chain_id))
          (fun ctxt =>
            match
              Data_encoding.Binary.of_bytes (|Chain_id|).(S.HASH.encoding)
                __bytes_value with
            | Some k => Error_monad.__return (k, ctxt)
            | None =>
              Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
            end)
      | (Script_typed_ir.Chain_id_t _, Micheline.String _ s) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt Typecheck_costs.chain_id))
          (fun ctxt =>
            match (|Chain_id|).(S.HASH.of_b58check_opt) s with
            | Some s => Error_monad.__return (s, ctxt)
            | None =>
              Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
            end)
      | (Script_typed_ir.Chain_id_t _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      | (Script_typed_ir.Address_t _, Micheline.Bytes loc __bytes_value) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt Typecheck_costs.contract))
          (fun ctxt =>
            match
              Data_encoding.Binary.of_bytes
                (Data_encoding.tup2 Alpha_context.Contract.encoding
                  Data_encoding.__Variable.__string_value) __bytes_value with
            | Some (c, entrypoint) =>
              if (|Compare.Int|).(Compare.S.op_gt) (String.length entrypoint) 31
                then
                Error_monad.fail extensible_type_value
              else
                Error_monad.op_gtgteqquestion
                  match entrypoint with
                  | "" => Error_monad.__return "default"
                  | "default" => Error_monad.fail extensible_type_value
                  | name => Error_monad.__return name
                  end
                  (fun entrypoint =>
                    Error_monad.__return ((c, entrypoint), ctxt))
            | None =>
              Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
            end)
      | (Script_typed_ir.Address_t _, Micheline.String loc s) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt Typecheck_costs.contract))
          (fun ctxt =>
            Error_monad.op_gtgteqquestion
              match String.index_opt s "%" % char with
              | None => Error_monad.__return (s, "default")
              | Some pos =>
                let len :=
                  Pervasives.op_minus
                    (Pervasives.op_minus (String.length s) pos) 1 in
                let name := String.sub s (Pervasives.op_plus pos 1) len in
                if (|Compare.Int|).(Compare.S.op_gt) len 31 then
                  Error_monad.fail extensible_type_value
                else
                  match ((String.sub s 0 pos), name) with
                  | (_, "default") =>
                    traced (Error_monad.fail extensible_type_value)
                  | addr_and_name => Error_monad.__return addr_and_name
                  end
              end
              (fun function_parameter =>
                let '(addr, entrypoint) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Lwt.__return (Alpha_context.Contract.of_b58check addr))
                  (fun c => Error_monad.__return ((c, entrypoint), ctxt))))
      | (Script_typed_ir.Address_t _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      | (Script_typed_ir.Contract_t ty _, Micheline.Bytes loc __bytes_value) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt Typecheck_costs.contract))
          (fun ctxt =>
            match
              Data_encoding.Binary.of_bytes
                (Data_encoding.tup2 Alpha_context.Contract.encoding
                  Data_encoding.__Variable.__string_value) __bytes_value with
            | Some (c, entrypoint) =>
              if (|Compare.Int|).(Compare.S.op_gt) (String.length entrypoint) 31
                then
                Error_monad.fail extensible_type_value
              else
                Error_monad.op_gtgteqquestion
                  match entrypoint with
                  | "" => Error_monad.__return "default"
                  | "default" => traced (Error_monad.fail extensible_type_value)
                  | name => Error_monad.__return name
                  end
                  (fun entrypoint =>
                    Error_monad.op_gtgteqquestion
                      (traced (parse_contract legacy ctxt loc ty c entrypoint))
                      (fun function_parameter =>
                        let '(ctxt, _) := function_parameter in
                        Error_monad.__return ((ty, (c, entrypoint)), ctxt)))
            | None =>
              Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
            end)
      | (Script_typed_ir.Contract_t ty _, Micheline.String loc s) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt Typecheck_costs.contract))
          (fun ctxt =>
            Error_monad.op_gtgteqquestion
              match String.index_opt s "%" % char with
              | None => Error_monad.__return (s, "default")
              | Some pos =>
                let len :=
                  Pervasives.op_minus
                    (Pervasives.op_minus (String.length s) pos) 1 in
                let name := String.sub s (Pervasives.op_plus pos 1) len in
                if (|Compare.Int|).(Compare.S.op_gt) len 31 then
                  Error_monad.fail extensible_type_value
                else
                  match ((String.sub s 0 pos), name) with
                  | (_, "default") =>
                    traced (Error_monad.fail extensible_type_value)
                  | addr_and_name => Error_monad.__return addr_and_name
                  end
              end
              (fun function_parameter =>
                let '(addr, entrypoint) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (traced
                    (Lwt.__return (Alpha_context.Contract.of_b58check addr)))
                  (fun c =>
                    Error_monad.op_gtgteqquestion
                      (parse_contract legacy ctxt loc ty c entrypoint)
                      (fun function_parameter =>
                        let '(ctxt, _) := function_parameter in
                        Error_monad.__return ((ty, (c, entrypoint)), ctxt)))))
      | (Script_typed_ir.Contract_t _ _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      |
        (Script_typed_ir.Pair_t (ta, _, _) (tb, _, _) _ _,
          Micheline.Prim loc Alpha_context.Script.D_Pair (cons va (cons vb []))
            annot) =>
        Error_monad.op_gtgteqquestion
          (if legacy then
            Error_monad.__return tt
          else
            Script_ir_annot.fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (Lwt.__return
                (Alpha_context.Gas.consume ctxt Typecheck_costs.pair))
              (fun ctxt =>
                Error_monad.op_gtgteqquestion
                  (Pervasives.op_atat traced
                    (parse_data type_logger ctxt legacy ta va))
                  (fun function_parameter =>
                    let '(va, ctxt) := function_parameter in
                    Error_monad.op_gtgteqquestion
                      (parse_data type_logger ctxt legacy tb vb)
                      (fun function_parameter =>
                        let '(vb, ctxt) := function_parameter in
                        Error_monad.__return ((va, vb), ctxt)))))
      |
        (Script_typed_ir.Pair_t _ _ _ _,
          Micheline.Prim loc Alpha_context.Script.D_Pair l _) =>
        Pervasives.op_atat Error_monad.fail extensible_type_value
      | (Script_typed_ir.Pair_t _ _ _ _, expr) =>
        traced
          (Error_monad.fail
            (unexpected expr [] Script_tc_errors.Constant_namespace
              [ Alpha_context.Script.D_Pair ]))
      |
        (Script_typed_ir.Union_t (tl, _) _ _ _,
          Micheline.Prim loc Alpha_context.Script.D_Left (cons v []) annot) =>
        Error_monad.op_gtgteqquestion
          (if legacy then
            Error_monad.__return tt
          else
            Script_ir_annot.fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (Lwt.__return
                (Alpha_context.Gas.consume ctxt Typecheck_costs.union))
              (fun ctxt =>
                Error_monad.op_gtgteqquestion
                  (Pervasives.op_atat traced
                    (parse_data type_logger ctxt legacy tl v))
                  (fun function_parameter =>
                    let '(v, ctxt) := function_parameter in
                    Error_monad.__return ((Script_typed_ir.L v), ctxt))))
      |
        (Script_typed_ir.Union_t _ _ _ _,
          Micheline.Prim loc Alpha_context.Script.D_Left l _) =>
        Pervasives.op_atat Error_monad.fail extensible_type_value
      |
        (Script_typed_ir.Union_t _ (tr, _) _ _,
          Micheline.Prim loc Alpha_context.Script.D_Right (cons v []) annot) =>
        Error_monad.op_gtgteqquestion
          (Script_ir_annot.fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (Lwt.__return
                (Alpha_context.Gas.consume ctxt Typecheck_costs.union))
              (fun ctxt =>
                Error_monad.op_gtgteqquestion
                  (Pervasives.op_atat traced
                    (parse_data type_logger ctxt legacy tr v))
                  (fun function_parameter =>
                    let '(v, ctxt) := function_parameter in
                    Error_monad.__return ((Script_typed_ir.R v), ctxt))))
      |
        (Script_typed_ir.Union_t _ _ _ _,
          Micheline.Prim loc Alpha_context.Script.D_Right l _) =>
        Pervasives.op_atat Error_monad.fail extensible_type_value
      | (Script_typed_ir.Union_t _ _ _ _, expr) =>
        traced
          (Error_monad.fail
            (unexpected expr [] Script_tc_errors.Constant_namespace
              [ Alpha_context.Script.D_Left; Alpha_context.Script.D_Right ]))
      |
        (Script_typed_ir.Lambda_t ta tr _ty_name,
          (Micheline.Seq _loc _) as script_instr) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt Typecheck_costs.lambda))
          (fun ctxt =>
            Pervasives.op_atat traced
              (parse_returning type_logger Lambda ctxt legacy
                (ta,
                  (Some
                    (* ❌ Variants not supported *)
                    (* ❌ `Var_annot *)
                    (Var_annot "@arg"))) tr script_instr))
      | (Script_typed_ir.Lambda_t _ _ _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      |
        (Script_typed_ir.Option_t __t_value _ _,
          Micheline.Prim loc Alpha_context.Script.D_Some (cons v []) annot) =>
        Error_monad.op_gtgteqquestion
          (if legacy then
            Error_monad.__return tt
          else
            Script_ir_annot.fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (Lwt.__return
                (Alpha_context.Gas.consume ctxt Typecheck_costs.some))
              (fun ctxt =>
                Error_monad.op_gtgteqquestion
                  (Pervasives.op_atat traced
                    (parse_data type_logger ctxt legacy __t_value v))
                  (fun function_parameter =>
                    let '(v, ctxt) := function_parameter in
                    Error_monad.__return ((Some v), ctxt))))
      |
        (Script_typed_ir.Option_t _ _ _,
          Micheline.Prim loc Alpha_context.Script.D_Some l _) =>
        Pervasives.op_atat Error_monad.fail extensible_type_value
      |
        (Script_typed_ir.Option_t _ _ _,
          Micheline.Prim loc Alpha_context.Script.D_None [] annot) =>
        Error_monad.op_gtgteqquestion
          (if legacy then
            Error_monad.__return tt
          else
            Script_ir_annot.fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (Lwt.__return
                (Alpha_context.Gas.consume ctxt Typecheck_costs.none))
              (fun ctxt => Error_monad.__return (None, ctxt)))
      |
        (Script_typed_ir.Option_t _ _ _,
          Micheline.Prim loc Alpha_context.Script.D_None l _) =>
        Pervasives.op_atat Error_monad.fail extensible_type_value
      | (Script_typed_ir.Option_t _ _ _, expr) =>
        traced
          (Error_monad.fail
            (unexpected expr [] Script_tc_errors.Constant_namespace
              [ Alpha_context.Script.D_Some; Alpha_context.Script.D_None ]))
      | (Script_typed_ir.List_t __t_value _ty_name _, Micheline.Seq _loc items)
        =>
        Pervasives.op_atat traced
          (Error_monad.fold_right_s
            (fun v =>
              fun function_parameter =>
                let '(rest, ctxt) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Lwt.__return
                    (Alpha_context.Gas.consume ctxt Typecheck_costs.list_element))
                  (fun ctxt =>
                    Error_monad.op_gtgteqquestion
                      (parse_data type_logger ctxt legacy __t_value v)
                      (fun function_parameter =>
                        let '(v, ctxt) := function_parameter in
                        Error_monad.__return ((cons v rest), ctxt)))) items
            ([], ctxt))
      | (Script_typed_ir.List_t _ _ _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      |
        (Script_typed_ir.Set_t __t_value _ty_name,
          (Micheline.Seq loc vs) as expr) =>
        let length := List.length vs in
        Error_monad.op_gtgtpipequestion
          (Pervasives.op_atat traced
            (Error_monad.fold_left_s
              (fun function_parameter =>
                let '(last_value, set, ctxt) := function_parameter in
                fun v =>
                  Error_monad.op_gtgteqquestion
                    (Lwt.__return
                      (Alpha_context.Gas.consume ctxt
                        (Typecheck_costs.set_element length)))
                    (fun ctxt =>
                      Error_monad.op_gtgteqquestion
                        (parse_comparable_data type_logger ctxt __t_value v)
                        (fun function_parameter =>
                          let '(v, ctxt) := function_parameter in
                          Error_monad.op_gtgteqquestion
                            match last_value with
                            | Some value =>
                              if
                                (|Compare.Int|).(Compare.S.op_lteq) 0
                                  (compare_comparable __t_value value v) then
                                if
                                  (|Compare.Int|).(Compare.S.op_eq) 0
                                    (compare_comparable __t_value value v) then
                                  Error_monad.fail extensible_type_value
                                else
                                  Error_monad.fail extensible_type_value
                              else
                                Error_monad.return_unit
                            | None => Error_monad.return_unit
                            end
                            (fun function_parameter =>
                              let '_ := function_parameter in
                              Error_monad.op_gtgteqquestion
                                (Lwt.__return
                                  (Alpha_context.Gas.consume ctxt
                                    (Michelson_v1_gas.Cost_of.Legacy.set_update
                                      v false set)))
                                (fun ctxt =>
                                  Error_monad.__return
                                    ((Some v), (set_update v true set), ctxt))))))
              (None, (empty_set __t_value), ctxt) vs))
          (fun function_parameter =>
            let '(_, set, ctxt) := function_parameter in
            (set, ctxt))
      | (Script_typed_ir.Set_t _ _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      | (Script_typed_ir.Map_t tk tv _ty_name _, (Micheline.Seq loc vs) as expr)
        => parse_items type_logger loc ctxt expr tk tv vs (fun x => x)
      | (Script_typed_ir.Map_t _ _ _ _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      |
        (Script_typed_ir.Big_map_t tk tv _ty_name,
          (Micheline.Seq loc vs) as expr) =>
        Error_monad.op_gtgtpipequestion
          (parse_items type_logger loc ctxt expr tk tv vs (fun x => Some x))
          (fun function_parameter =>
            let '(diff, ctxt) := function_parameter in
            ({| Script_typed_ir.big_map.id := None;
              Script_typed_ir.big_map.diff := diff;
              Script_typed_ir.big_map.key_type := ty_of_comparable_ty tk;
              Script_typed_ir.big_map.value_type := tv |}, ctxt))
      | (Script_typed_ir.Big_map_t tk tv _ty_name, Micheline.Int loc id) =>
        Error_monad.op_gtgteqquestion (Alpha_context.Big_map.__exists ctxt id)
          (fun function_parameter =>
            match function_parameter with
            | (_, None) => traced (Error_monad.fail extensible_type_value)
            | (ctxt, Some (btk, btv)) =>
              Lwt.__return
                (Error_monad.op_gtgtquestion
                  (parse_comparable_ty ctxt (Micheline.root btk))
                  (fun function_parameter =>
                    let '(Ex_comparable_ty btk, ctxt) := function_parameter in
                    Error_monad.op_gtgtquestion
                      (parse_packable_ty ctxt legacy (Micheline.root btv))
                      (fun function_parameter =>
                        let '(Ex_ty btv, ctxt) := function_parameter in
                        Error_monad.op_gtgtquestion
                          (comparable_ty_eq ctxt tk btk)
                          (fun function_parameter =>
                            let 'Eq := function_parameter in
                            Error_monad.op_gtgtquestion (ty_eq ctxt tv btv)
                              (fun function_parameter =>
                                let '(Eq, ctxt) := function_parameter in
                                Error_monad.ok
                                  ({| Script_typed_ir.big_map.id := Some id;
                                    Script_typed_ir.big_map.diff := empty_map tk;
                                    Script_typed_ir.big_map.key_type :=
                                      ty_of_comparable_ty tk;
                                    Script_typed_ir.big_map.value_type := tv |},
                                    ctxt))))))
            end)
      | (Script_typed_ir.Big_map_t _tk _tv _, expr) =>
        traced (Error_monad.fail extensible_type_value)
      end)

with parse_comparable_data {a : Set}
  (type_logger : option type_logger) (ctxt : Alpha_context.context)
  (ty : Script_typed_ir.comparable_ty a)
  (script_data : Alpha_context.Script.node) {struct type_logger}
  : Lwt.t (Error_monad.tzresult (a * Alpha_context.context)) :=
  parse_data type_logger ctxt false (ty_of_comparable_ty ty) script_data

with parse_returning {arg ret : Set}
  (type_logger : option type_logger) (tc_context : tc_context)
  (ctxt : Alpha_context.context) (legacy : bool)
  (function_parameter :
    Script_typed_ir.ty arg * option Script_typed_ir.var_annot)
  {struct type_logger}
  : Script_typed_ir.ty ret -> Alpha_context.Script.node ->
  Lwt.t
    (Error_monad.tzresult
      (Script_typed_ir.lambda arg ret * Alpha_context.context)) :=
  let '(arg, arg_annot) := function_parameter in
  fun ret =>
    fun script_instr =>
      Error_monad.op_gtgteqquestion
        (parse_instr type_logger tc_context ctxt legacy script_instr
          (Script_typed_ir.Item_t arg Script_typed_ir.Empty_t arg_annot))
        (fun function_parameter =>
          match function_parameter with
          |
            (Typed
              ({|
                Script_typed_ir.descr.loc := loc;
                  Script_typed_ir.descr.aft :=
                    (Script_typed_ir.Item_t ty
                      Script_typed_ir.Empty_t _) as
                      stack_ty
                  |} as __descr_value), ctxt) =>
            Error_monad.trace_eval
              (fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Lwt.__return (serialize_ty_for_error ctxt ret))
                  (fun function_parameter =>
                    let '(ret, ctxt) := function_parameter in
                    Error_monad.op_gtgtpipequestion
                      (serialize_stack_for_error ctxt stack_ty)
                      (fun function_parameter =>
                        let '(stack_ty, _ctxt) := function_parameter in
                        extensible_type_value)))
              (Error_monad.op_gtgteqquestion (Lwt.__return (ty_eq ctxt ty ret))
                (fun function_parameter =>
                  let '(Eq, ctxt) := function_parameter in
                  Error_monad.op_gtgteqquestion
                    (Lwt.__return (merge_types legacy ctxt loc ty ret))
                    (fun function_parameter =>
                      let '(_ret, ctxt) := function_parameter in
                      Error_monad.__return
                        ((Script_typed_ir.Lam __descr_value script_instr), ctxt))))
          |
            (Typed {|
              Script_typed_ir.descr.loc := loc;
                Script_typed_ir.descr.aft := stack_ty
                |}, ctxt) =>
            Error_monad.op_gtgteqquestion
              (Lwt.__return (serialize_ty_for_error ctxt ret))
              (fun function_parameter =>
                let '(ret, ctxt) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (serialize_stack_for_error ctxt stack_ty)
                  (fun function_parameter =>
                    let '(stack_ty, _ctxt) := function_parameter in
                    Error_monad.fail extensible_type_value))
          | (Failed {| judgement.Failed.descr := __descr_value |}, ctxt) =>
            Error_monad.__return
              ((Script_typed_ir.Lam
                (__descr_value
                  (Script_typed_ir.Item_t ret Script_typed_ir.Empty_t None))
                script_instr), ctxt)
          end)

with parse_int32
  (n : Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
  {struct n} : Error_monad.tzresult Z :=
  let error' (function_parameter : unit) : Error_monad.__error :=
    let '_ := function_parameter in
    extensible_type_value in
  match n with
  | Micheline.Int _ n' =>
    (* ❌ Try-with are not handled *)
    try
      (let n'' := Z.to_int n' in
      if
        Pervasives.op_andand ((|Compare.Int|).(Compare.S.op_lteq) 0 n'')
          ((|Compare.Int|).(Compare.S.op_lteq) n'' (Int32.to_int Int32.max_int))
        then
        Error_monad.ok n''
      else
        Pervasives.op_atat Error_monad.__error_value (error' tt))
  | _ => Pervasives.op_atat Error_monad.__error_value (error' tt)
  end

with parse_instr {bef : Set}
  (type_logger : option type_logger) (tc_context : tc_context)
  (ctxt : Alpha_context.context) (legacy : bool)
  (script_instr : Alpha_context.Script.node)
  (stack_ty : Script_typed_ir.stack_ty bef) {struct type_logger}
  : Lwt.t (Error_monad.tzresult (judgement bef * Alpha_context.context)) :=
  let _check_item {B : Set}
    (check : Error_monad.tzresult B) (loc : Alpha_context.Script.location)
    (name : Alpha_context.Script.prim) (n : Z) (m : Z)
    : Lwt.t (Error_monad.tzresult B) :=
    Pervasives.op_atat
      (Error_monad.trace_eval
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgtpipequestion
            (serialize_stack_for_error ctxt stack_ty)
            (fun function_parameter =>
              let '(stack_ty, _ctxt) := function_parameter in
              extensible_type_value)))
      (Pervasives.op_atat (Error_monad.trace extensible_type_value)
        (Lwt.__return check)) in
  let check_item_ty {B C : Set}
    (ctxt : Alpha_context.context) (exp : Script_typed_ir.ty B)
    (got : Script_typed_ir.ty C) (loc : Alpha_context.Script.location)
    (name : Alpha_context.Script.prim) (n : Z) (m : Z)
    : Lwt.t
      (Error_monad.tzresult
        (eq B C * Script_typed_ir.ty B * Alpha_context.context)) :=
    Pervasives.op_atat
      (Error_monad.trace_eval
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgtpipequestion
            (serialize_stack_for_error ctxt stack_ty)
            (fun function_parameter =>
              let '(stack_ty, _ctxt) := function_parameter in
              extensible_type_value)))
      (Pervasives.op_atat (Error_monad.trace extensible_type_value)
        (Lwt.__return
          (Error_monad.op_gtgtquestion (ty_eq ctxt exp got)
            (fun function_parameter =>
              let '(Eq, ctxt) := function_parameter in
              Error_monad.op_gtgtquestion (merge_types legacy ctxt loc exp got)
                (fun function_parameter =>
                  let '(ty, ctxt) := function_parameter in
                  Error_monad.ok (Eq, ty, ctxt)))))) in
  let check_item_comparable_ty {B C : Set}
    (exp : Script_typed_ir.comparable_ty B)
    (got : Script_typed_ir.comparable_ty C)
    (loc : Alpha_context.Script.location) (name : Alpha_context.Script.prim)
    (n : Z) (m : Z)
    : Lwt.t (Error_monad.tzresult (eq B C * Script_typed_ir.comparable_ty B)) :=
    Pervasives.op_atat
      (Error_monad.trace_eval
        (fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgtpipequestion
            (serialize_stack_for_error ctxt stack_ty)
            (fun function_parameter =>
              let '(stack_ty, _ctxt) := function_parameter in
              extensible_type_value)))
      (Pervasives.op_atat (Error_monad.trace extensible_type_value)
        (Lwt.__return
          (Error_monad.op_gtgtquestion (comparable_ty_eq ctxt exp got)
            (fun function_parameter =>
              let 'Eq := function_parameter in
              Error_monad.op_gtgtquestion
                (merge_comparable_types legacy exp got)
                (fun ty => Error_monad.ok (Eq, ty)))))) in
  let log_stack {B C : Set}
    (ctxt : Alpha_context.context) (loc : Z)
    (stack_ty : Script_typed_ir.stack_ty B) (aft : Script_typed_ir.stack_ty C)
    : Lwt.t (Error_monad.tzresult unit) :=
    match (type_logger, script_instr) with
    |
      (None, _) |
      (Some _,
        Micheline.Seq (-1) _ | Micheline.Int _ _ | Micheline.String _ _ |
        Micheline.Bytes _ _) => Error_monad.return_unit
    | (Some log, Micheline.Prim _ _ _ _ | Micheline.Seq _ _) =>
      let ctxt := Alpha_context.Gas.set_unlimited ctxt in
      Error_monad.op_gtgteqquestion (unparse_stack ctxt stack_ty)
        (fun function_parameter =>
          let '(stack_ty, _) := function_parameter in
          Error_monad.op_gtgteqquestion (unparse_stack ctxt aft)
            (fun function_parameter =>
              let '(aft, _) := function_parameter in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              (* ❌ instruction_sequence ";" *)
              Error_monad.return_unit))
    end in
  let outer_return := Error_monad.__return in
  let __return (ctxt : Alpha_context.context) (judgement : judgement bef)
    : Lwt.t (Error_monad.tzresult (judgement bef * Alpha_context.context)) :=
    match judgement with
    |
      Typed {|
        Script_typed_ir.descr.loc := loc;
          Script_typed_ir.descr.aft := aft;
          Script_typed_ir.descr.instr := instr
          |} =>
      let maximum_type_size :=
        Alpha_context.Constants.michelson_maximum_type_size ctxt in
      let type_size :=
        type_size_of_stack_head aft (number_of_generated_growing_types instr) in
      if (|Compare.Int|).(Compare.S.op_gt) type_size maximum_type_size then
        Error_monad.fail extensible_type_value
      else
        Error_monad.__return (judgement, ctxt)
    | Failed _ => Error_monad.__return (judgement, ctxt)
    end in
  let typed {B : Set}
    (ctxt : Alpha_context.context) (loc : Z)
    (instr : Script_typed_ir.instr bef B) (aft : Script_typed_ir.stack_ty B)
    : Lwt.t (Error_monad.tzresult (judgement bef * Alpha_context.context)) :=
    Error_monad.op_gtgteqquestion (log_stack ctxt loc stack_ty aft)
      (fun function_parameter =>
        let '_ := function_parameter in
        Error_monad.op_gtgteqquestion
          (Pervasives.op_atat Lwt.__return
            (Alpha_context.Gas.consume ctxt (Typecheck_costs.instr instr)))
          (fun ctxt =>
            __return ctxt
              (Typed
                {| Script_typed_ir.descr.loc := loc;
                  Script_typed_ir.descr.bef := stack_ty;
                  Script_typed_ir.descr.aft := aft;
                  Script_typed_ir.descr.instr := instr |}))) in
  Error_monad.op_gtgteqquestion
    (Pervasives.op_atat Lwt.__return
      (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
    (fun ctxt =>
      match
        ((script_instr, stack_ty),
          match (script_instr, stack_ty) with
          |
            (Micheline.Prim loc Alpha_context.Script.I_DIP
              (cons n (cons code [])) result_annot, stack) =>
            match parse_int32 n with
            | Pervasives.Ok _ => true
            | Pervasives.Error _ => false
            end
          | _ => false
          end) with
      |
        ((Micheline.Prim loc Alpha_context.Script.I_DROP [] annot,
          Script_typed_ir.Item_t _ rest _), _) =>
        Error_monad.op_gtgteqquestion
          (Script_ir_annot.fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let '_ := function_parameter in
            typed ctxt loc Script_typed_ir.Drop rest)
      |
        ((Micheline.Prim loc Alpha_context.Script.I_DROP (cons n [])
          result_annot, whole_stack), _) =>
        Error_monad.op_gtgteqquestion (Lwt.__return (parse_int32 n))
          (fun whole_n =>
            let fix make_proof_argument {tstk : Set}
              (n : Z) (stk : Script_typed_ir.stack_ty tstk) {struct n}
              : Lwt.t (Error_monad.tzresult (dropn_proof_argument tstk)) :=
              match (((|Compare.Int|).(Compare.S.op_eq) n 0), stk) with
              | (true, rest) =>
                Pervasives.op_atat outer_return
                  (Dropn_proof_argument (Script_typed_ir.Rest, rest, rest))
              | (false, Script_typed_ir.Item_t v rest annot) =>
                Error_monad.op_gtgteqquestion
                  (make_proof_argument (Pervasives.op_minus n 1) rest)
                  (fun function_parameter =>
                    let 'Dropn_proof_argument (n', stack_after_drops, aft') :=
                      function_parameter in
                    Pervasives.op_atat outer_return
                      (Dropn_proof_argument
                        ((Script_typed_ir.Prefix n'), stack_after_drops,
                          (Script_typed_ir.Item_t v aft' annot))))
              | (_, _) =>
                Error_monad.op_gtgteqquestion
                  (serialize_stack_for_error ctxt whole_stack)
                  (fun function_parameter =>
                    let '(whole_stack, _ctxt) := function_parameter in
                    Error_monad.fail extensible_type_value)
              end in
            Error_monad.op_gtgteqquestion
              (Script_ir_annot.fail_unexpected_annot loc result_annot)
              (fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.op_gtgteqquestion
                  (make_proof_argument whole_n whole_stack)
                  (fun function_parameter =>
                    let 'Dropn_proof_argument (n', stack_after_drops, _aft) :=
                      function_parameter in
                    typed ctxt loc (Script_typed_ir.Dropn whole_n n')
                      stack_after_drops)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_DROP
          ((cons _ (cons _ _)) as l) _, _), _) =>
        Error_monad.fail extensible_type_value
      |
        ((Micheline.Prim loc Alpha_context.Script.I_DUP [] annot,
          Script_typed_ir.Item_t v rest stack_annot), _) =>
        Error_monad.op_gtgteqquestion
          (parse_var_annot loc (Some stack_annot) annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Dup
              (Script_typed_ir.Item_t v
                (Script_typed_ir.Item_t v rest stack_annot) annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_DIG (cons n []) result_annot,
          stack), _) =>
        let fix make_proof_argument {tstk : Set}
          (n : Z) (stk : Script_typed_ir.stack_ty tstk) {struct n}
          : Lwt.t (Error_monad.tzresult (dig_proof_argument tstk)) :=
          match (((|Compare.Int|).(Compare.S.op_eq) n 0), stk) with
          | (true, Script_typed_ir.Item_t v rest annot) =>
            Pervasives.op_atat outer_return
              (Dig_proof_argument (Script_typed_ir.Rest, (v, annot), rest))
          | (false, Script_typed_ir.Item_t v rest annot) =>
            Error_monad.op_gtgteqquestion
              (make_proof_argument (Pervasives.op_minus n 1) rest)
              (fun function_parameter =>
                let 'Dig_proof_argument (n', (x, xv), aft') :=
                  function_parameter in
                Pervasives.op_atat outer_return
                  (Dig_proof_argument
                    ((Script_typed_ir.Prefix n'), (x, xv),
                      (Script_typed_ir.Item_t v aft' annot))))
          | (_, _) =>
            Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
              (fun function_parameter =>
                let '(whole_stack, _ctxt) := function_parameter in
                Error_monad.fail extensible_type_value)
          end in
        Error_monad.op_gtgteqquestion (Lwt.__return (parse_int32 n))
          (fun n =>
            Error_monad.op_gtgteqquestion
              (Script_ir_annot.fail_unexpected_annot loc result_annot)
              (fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.op_gtgteqquestion (make_proof_argument n stack)
                  (fun function_parameter =>
                    let 'Dig_proof_argument (n', (x, stack_annot), aft) :=
                      function_parameter in
                    typed ctxt loc (Script_typed_ir.Dig n n')
                      (Script_typed_ir.Item_t x aft stack_annot))))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_DIG
          (([] | cons _ (cons _ _)) as l) _, _), _) =>
        Error_monad.fail extensible_type_value
      |
        ((Micheline.Prim loc Alpha_context.Script.I_DUG (cons n []) result_annot,
          Script_typed_ir.Item_t x whole_stack stack_annot), _) =>
        Error_monad.op_gtgteqquestion (Lwt.__return (parse_int32 n))
          (fun whole_n =>
            let fix make_proof_argument {tstk x : Set}
              (n : Z) (x : Script_typed_ir.ty x)
              (stack_annot : option Script_typed_ir.var_annot)
              (stk : Script_typed_ir.stack_ty tstk) {struct n}
              : Lwt.t (Error_monad.tzresult (dug_proof_argument tstk x)) :=
              match (((|Compare.Int|).(Compare.S.op_eq) n 0), stk) with
              | (true, rest) =>
                Pervasives.op_atat outer_return
                  (Dug_proof_argument
                    (Script_typed_ir.Rest, tt,
                      (Script_typed_ir.Item_t x rest stack_annot)))
              | (false, Script_typed_ir.Item_t v rest annot) =>
                Error_monad.op_gtgteqquestion
                  (make_proof_argument (Pervasives.op_minus n 1) x stack_annot
                    rest)
                  (fun function_parameter =>
                    let 'Dug_proof_argument (n', _, aft') := function_parameter
                      in
                    Pervasives.op_atat outer_return
                      (Dug_proof_argument
                        ((Script_typed_ir.Prefix n'), tt,
                          (Script_typed_ir.Item_t v aft' annot))))
              | (_, _) =>
                Error_monad.op_gtgteqquestion
                  (serialize_stack_for_error ctxt whole_stack)
                  (fun function_parameter =>
                    let '(whole_stack, _ctxt) := function_parameter in
                    Error_monad.fail extensible_type_value)
              end in
            Error_monad.op_gtgteqquestion
              (Script_ir_annot.fail_unexpected_annot loc result_annot)
              (fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.op_gtgteqquestion
                  (make_proof_argument whole_n x stack_annot whole_stack)
                  (fun function_parameter =>
                    let 'Dug_proof_argument (n', _, aft) := function_parameter
                      in
                    typed ctxt loc (Script_typed_ir.Dug whole_n n') aft)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_DUG (cons _ []) result_annot,
          Script_typed_ir.Empty_t as stack), _) =>
        Error_monad.op_gtgteqquestion
          (Script_ir_annot.fail_unexpected_annot loc result_annot)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
              (fun function_parameter =>
                let '(stack, _ctxt) := function_parameter in
                Error_monad.fail extensible_type_value))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_DUG
          (([] | cons _ (cons _ _)) as l) _, _), _) =>
        Error_monad.fail extensible_type_value
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SWAP [] annot,
          Script_typed_ir.Item_t v (Script_typed_ir.Item_t w rest stack_annot)
            cur_top_annot), _) =>
        Error_monad.op_gtgteqquestion
          (Script_ir_annot.fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let '_ := function_parameter in
            typed ctxt loc Script_typed_ir.Swap
              (Script_typed_ir.Item_t w
                (Script_typed_ir.Item_t v rest cur_top_annot) stack_annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_PUSH
          (cons __t_value (cons d [])) annot, stack), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (parse_packable_ty ctxt legacy __t_value))
              (fun function_parameter =>
                let '(Ex_ty __t_value, ctxt) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (parse_data type_logger ctxt legacy __t_value d)
                  (fun function_parameter =>
                    let '(v, ctxt) := function_parameter in
                    typed ctxt loc (Script_typed_ir.Const v)
                      (Script_typed_ir.Item_t __t_value stack annot))))
      | ((Micheline.Prim loc Alpha_context.Script.I_UNIT [] annot, stack), _) =>
        Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
          (fun function_parameter =>
            let '(annot, ty_name) := function_parameter in
            typed ctxt loc (Script_typed_ir.Const tt)
              (Script_typed_ir.Item_t (Script_typed_ir.Unit_t ty_name) stack
                annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SOME [] annot,
          Script_typed_ir.Item_t __t_value rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
          (fun function_parameter =>
            let '(annot, ty_name) := function_parameter in
            typed ctxt loc Script_typed_ir.Cons_some
              (Script_typed_ir.Item_t
                (Script_typed_ir.Option_t __t_value ty_name
                  (has_big_map __t_value)) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_NONE (cons __t_value [])
          annot, stack), _) =>
        Error_monad.op_gtgteqquestion
          (Pervasives.op_atat Lwt.__return (parse_any_ty ctxt legacy __t_value))
          (fun function_parameter =>
            let '(Ex_ty __t_value, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
              (fun function_parameter =>
                let '(annot, ty_name) := function_parameter in
                typed ctxt loc (Script_typed_ir.Cons_none __t_value)
                  (Script_typed_ir.Item_t
                    (Script_typed_ir.Option_t __t_value ty_name
                      (has_big_map __t_value)) stack annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_IF_NONE
          (cons bt (cons bf [])) annot,
          (Script_typed_ir.Item_t (Script_typed_ir.Option_t __t_value _ _) rest
            option_annot) as bef), _) =>
        Error_monad.op_gtgteqquestion
          (check_kind [ Script_tc_errors.Seq_kind ] bt)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (check_kind [ Script_tc_errors.Seq_kind ] bf)
              (fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Script_ir_annot.fail_unexpected_annot loc annot)
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    let annot :=
                      Script_ir_annot.gen_access_annot option_annot None
                        Script_ir_annot.default_some_annot in
                    Error_monad.op_gtgteqquestion
                      (parse_instr type_logger tc_context ctxt legacy bt rest)
                      (fun function_parameter =>
                        let '(btr, ctxt) := function_parameter in
                        Error_monad.op_gtgteqquestion
                          (parse_instr type_logger tc_context ctxt legacy bf
                            (Script_typed_ir.Item_t __t_value rest annot))
                          (fun function_parameter =>
                            let '(bfr, ctxt) := function_parameter in
                            let branch {B : Set}
                              (ibt : Script_typed_ir.descr __57 B)
                              (ibf : Script_typed_ir.descr (__58 * __57) B)
                              : Script_typed_ir.descr (option __58 * __57) B :=
                              {| Script_typed_ir.descr.loc := loc;
                                Script_typed_ir.descr.bef := bef;
                                Script_typed_ir.descr.aft :=
                                  Script_typed_ir.descr.aft ibt;
                                Script_typed_ir.descr.instr :=
                                  Script_typed_ir.If_none ibt ibf |} in
                            Error_monad.op_gtgteqquestion
                              (merge_branches legacy ctxt loc btr bfr
                                {| branch.branch := branch |})
                              (fun function_parameter =>
                                let '(judgement, ctxt) := function_parameter in
                                __return ctxt judgement))))))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_PAIR [] annot,
          Script_typed_ir.Item_t a (Script_typed_ir.Item_t b rest snd_annot)
            fst_annot), _) =>
        Error_monad.op_gtgteqquestion
          (parse_constr_annot loc
            (Some (Script_ir_annot.var_to_field_annot fst_annot))
            (Some (Script_ir_annot.var_to_field_annot snd_annot)) annot)
          (fun function_parameter =>
            let '(annot, ty_name, l_field, r_field) := function_parameter in
            typed ctxt loc Script_typed_ir.Cons_pair
              (Script_typed_ir.Item_t
                (Script_typed_ir.Pair_t (a, l_field, fst_annot)
                  (b, r_field, snd_annot) ty_name
                  (Pervasives.op_pipepipe (has_big_map a) (has_big_map b))) rest
                annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_CAR [] annot,
          Script_typed_ir.Item_t
            (Script_typed_ir.Pair_t (a, expected_field_annot, a_annot) _ _ _)
            rest pair_annot), _) =>
        Error_monad.op_gtgteqquestion
          (parse_destr_annot loc annot Script_ir_annot.default_car_annot
            expected_field_annot pair_annot a_annot)
          (fun function_parameter =>
            let '(annot, field_annot) := function_parameter in
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.check_correct_field field_annot
                  expected_field_annot))
              (fun function_parameter =>
                let '_ := function_parameter in
                typed ctxt loc Script_typed_ir.Car
                  (Script_typed_ir.Item_t a rest annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_CDR [] annot,
          Script_typed_ir.Item_t
            (Script_typed_ir.Pair_t _ (b, expected_field_annot, b_annot) _ _)
            rest pair_annot), _) =>
        Error_monad.op_gtgteqquestion
          (parse_destr_annot loc annot Script_ir_annot.default_cdr_annot
            expected_field_annot pair_annot b_annot)
          (fun function_parameter =>
            let '(annot, field_annot) := function_parameter in
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.check_correct_field field_annot
                  expected_field_annot))
              (fun function_parameter =>
                let '_ := function_parameter in
                typed ctxt loc Script_typed_ir.Cdr
                  (Script_typed_ir.Item_t b rest annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_LEFT (cons tr []) annot,
          Script_typed_ir.Item_t tl rest stack_annot), _) =>
        Error_monad.op_gtgteqquestion
          (Pervasives.op_atat Lwt.__return (parse_any_ty ctxt legacy tr))
          (fun function_parameter =>
            let '(Ex_ty tr, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion
              (parse_constr_annot loc
                (Some (Script_ir_annot.var_to_field_annot stack_annot)) None
                annot)
              (fun function_parameter =>
                let '(annot, tname, l_field, r_field) := function_parameter in
                typed ctxt loc Script_typed_ir.Left
                  (Script_typed_ir.Item_t
                    (Script_typed_ir.Union_t (tl, l_field) (tr, r_field) tname
                      (Pervasives.op_pipepipe (has_big_map tl) (has_big_map tr)))
                    rest annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_RIGHT (cons tl []) annot,
          Script_typed_ir.Item_t tr rest stack_annot), _) =>
        Error_monad.op_gtgteqquestion
          (Pervasives.op_atat Lwt.__return (parse_any_ty ctxt legacy tl))
          (fun function_parameter =>
            let '(Ex_ty tl, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion
              (parse_constr_annot loc None
                (Some (Script_ir_annot.var_to_field_annot stack_annot)) annot)
              (fun function_parameter =>
                let '(annot, tname, l_field, r_field) := function_parameter in
                typed ctxt loc Script_typed_ir.Right
                  (Script_typed_ir.Item_t
                    (Script_typed_ir.Union_t (tl, l_field) (tr, r_field) tname
                      (Pervasives.op_pipepipe (has_big_map tl) (has_big_map tr)))
                    rest annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_IF_LEFT
          (cons bt (cons bf [])) annot,
          (Script_typed_ir.Item_t
            (Script_typed_ir.Union_t (tl, l_field) (tr, r_field) _ _) rest
            union_annot) as bef), _) =>
        Error_monad.op_gtgteqquestion
          (check_kind [ Script_tc_errors.Seq_kind ] bt)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (check_kind [ Script_tc_errors.Seq_kind ] bf)
              (fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Script_ir_annot.fail_unexpected_annot loc annot)
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    let left_annot :=
                      Script_ir_annot.gen_access_annot union_annot
                        (Some Script_ir_annot.default_left_annot) l_field in
                    let right_annot :=
                      Script_ir_annot.gen_access_annot union_annot
                        (Some Script_ir_annot.default_right_annot) r_field in
                    Error_monad.op_gtgteqquestion
                      (parse_instr type_logger tc_context ctxt legacy bt
                        (Script_typed_ir.Item_t tl rest left_annot))
                      (fun function_parameter =>
                        let '(btr, ctxt) := function_parameter in
                        Error_monad.op_gtgteqquestion
                          (parse_instr type_logger tc_context ctxt legacy bf
                            (Script_typed_ir.Item_t tr rest right_annot))
                          (fun function_parameter =>
                            let '(bfr, ctxt) := function_parameter in
                            let branch {B : Set}
                              (ibt : Script_typed_ir.descr (__77 * __76) B)
                              (ibf : Script_typed_ir.descr (__78 * __76) B)
                              : Script_typed_ir.descr
                                (Script_typed_ir.union __77 __78 * __76) B :=
                              {| Script_typed_ir.descr.loc := loc;
                                Script_typed_ir.descr.bef := bef;
                                Script_typed_ir.descr.aft :=
                                  Script_typed_ir.descr.aft ibt;
                                Script_typed_ir.descr.instr :=
                                  Script_typed_ir.If_left ibt ibf |} in
                            Error_monad.op_gtgteqquestion
                              (merge_branches legacy ctxt loc btr bfr
                                {| branch.branch := branch |})
                              (fun function_parameter =>
                                let '(judgement, ctxt) := function_parameter in
                                __return ctxt judgement))))))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_NIL (cons __t_value [])
          annot, stack), _) =>
        Error_monad.op_gtgteqquestion
          (Pervasives.op_atat Lwt.__return (parse_any_ty ctxt legacy __t_value))
          (fun function_parameter =>
            let '(Ex_ty __t_value, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
              (fun function_parameter =>
                let '(annot, ty_name) := function_parameter in
                typed ctxt loc Script_typed_ir.Nil
                  (Script_typed_ir.Item_t
                    (Script_typed_ir.List_t __t_value ty_name
                      (has_big_map __t_value)) stack annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_CONS [] annot,
          Script_typed_ir.Item_t tv
            (Script_typed_ir.Item_t
              (Script_typed_ir.List_t __t_value ty_name has_big_map) rest _) _),
          _) =>
        Error_monad.op_gtgteqquestion
          (check_item_ty ctxt tv __t_value loc Alpha_context.Script.I_CONS 1 2)
          (fun function_parameter =>
            let '(Eq, __t_value, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
              (fun annot =>
                typed ctxt loc Script_typed_ir.Cons_list
                  (Script_typed_ir.Item_t
                    (Script_typed_ir.List_t __t_value ty_name has_big_map) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_IF_CONS
          (cons bt (cons bf [])) annot,
          (Script_typed_ir.Item_t
            (Script_typed_ir.List_t __t_value ty_name has_big_map) rest
            list_annot) as bef), _) =>
        Error_monad.op_gtgteqquestion
          (check_kind [ Script_tc_errors.Seq_kind ] bt)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (check_kind [ Script_tc_errors.Seq_kind ] bf)
              (fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Script_ir_annot.fail_unexpected_annot loc annot)
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    let hd_annot :=
                      Script_ir_annot.gen_access_annot list_annot None
                        Script_ir_annot.default_hd_annot in
                    let tl_annot :=
                      Script_ir_annot.gen_access_annot list_annot None
                        Script_ir_annot.default_tl_annot in
                    Error_monad.op_gtgteqquestion
                      (parse_instr type_logger tc_context ctxt legacy bt
                        (Script_typed_ir.Item_t __t_value
                          (Script_typed_ir.Item_t
                            (Script_typed_ir.List_t __t_value ty_name
                              has_big_map) rest tl_annot) hd_annot))
                      (fun function_parameter =>
                        let '(btr, ctxt) := function_parameter in
                        Error_monad.op_gtgteqquestion
                          (parse_instr type_logger tc_context ctxt legacy bf
                            rest)
                          (fun function_parameter =>
                            let '(bfr, ctxt) := function_parameter in
                            let branch {B : Set}
                              (ibt :
                                Script_typed_ir.descr
                                  (__86 * (list __86 * __85)) B)
                              (ibf : Script_typed_ir.descr __85 B)
                              : Script_typed_ir.descr (list __86 * __85) B :=
                              {| Script_typed_ir.descr.loc := loc;
                                Script_typed_ir.descr.bef := bef;
                                Script_typed_ir.descr.aft :=
                                  Script_typed_ir.descr.aft ibt;
                                Script_typed_ir.descr.instr :=
                                  Script_typed_ir.If_cons ibt ibf |} in
                            Error_monad.op_gtgteqquestion
                              (merge_branches legacy ctxt loc btr bfr
                                {| branch.branch := branch |})
                              (fun function_parameter =>
                                let '(judgement, ctxt) := function_parameter in
                                __return ctxt judgement))))))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SIZE [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.List_t _ _ _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
          (fun function_parameter =>
            let '(annot, tname) := function_parameter in
            typed ctxt loc Script_typed_ir.List_size
              (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_MAP (cons body []) annot,
          Script_typed_ir.Item_t (Script_typed_ir.List_t elt _ _) starting_rest
            list_annot), _) =>
        Error_monad.op_gtgteqquestion
          (check_kind [ Script_tc_errors.Seq_kind ] body)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
              (fun function_parameter =>
                let '(ret_annot, list_ty_name) := function_parameter in
                let elt_annot :=
                  Script_ir_annot.gen_access_annot list_annot None
                    Script_ir_annot.default_elt_annot in
                Error_monad.op_gtgteqquestion
                  (parse_instr type_logger tc_context ctxt legacy body
                    (Script_typed_ir.Item_t elt starting_rest elt_annot))
                  (fun function_parameter =>
                    let '(judgement, ctxt) := function_parameter in
                    match judgement with
                    |
                      Typed
                        ({|
                          Script_typed_ir.descr.aft := Script_typed_ir.Item_t ret rest _
                            |} as ibody) =>
                      let invalid_map_body (function_parameter : unit)
                        : Lwt.t (Error_monad.tzresult Error_monad.__error) :=
                        let '_ := function_parameter in
                        Error_monad.op_gtgtpipequestion
                          (serialize_stack_for_error ctxt
                            (Script_typed_ir.descr.aft ibody))
                          (fun function_parameter =>
                            let '(aft, _ctxt) := function_parameter in
                            extensible_type_value) in
                      Error_monad.trace_eval invalid_map_body
                        (Error_monad.op_gtgteqquestion
                          (Pervasives.op_atat Lwt.__return
                            (stack_ty_eq ctxt 1 rest starting_rest))
                          (fun function_parameter =>
                            let '(Eq, ctxt) := function_parameter in
                            Error_monad.op_gtgteqquestion
                              (Pervasives.op_atat Lwt.__return
                                (merge_stacks legacy loc ctxt rest starting_rest))
                              (fun function_parameter =>
                                let '(rest, ctxt) := function_parameter in
                                typed ctxt loc (Script_typed_ir.List_map ibody)
                                  (Script_typed_ir.Item_t
                                    (Script_typed_ir.List_t ret list_ty_name
                                      (has_big_map ret)) rest ret_annot))))
                    | Typed {| Script_typed_ir.descr.aft := aft |} =>
                      Error_monad.op_gtgteqquestion
                        (serialize_stack_for_error ctxt aft)
                        (fun function_parameter =>
                          let '(aft, _ctxt) := function_parameter in
                          Error_monad.fail extensible_type_value)
                    | Failed _ => Error_monad.fail extensible_type_value
                    end)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_ITER (cons body []) annot,
          Script_typed_ir.Item_t (Script_typed_ir.List_t elt _ _) rest
            list_annot), _) =>
        Error_monad.op_gtgteqquestion
          (check_kind [ Script_tc_errors.Seq_kind ] body)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (Script_ir_annot.fail_unexpected_annot loc annot)
              (fun function_parameter =>
                let '_ := function_parameter in
                let elt_annot :=
                  Script_ir_annot.gen_access_annot list_annot None
                    Script_ir_annot.default_elt_annot in
                Error_monad.op_gtgteqquestion
                  (parse_instr type_logger tc_context ctxt legacy body
                    (Script_typed_ir.Item_t elt rest elt_annot))
                  (fun function_parameter =>
                    let '(judgement, ctxt) := function_parameter in
                    match judgement with
                    | Typed ({| Script_typed_ir.descr.aft := aft |} as ibody) =>
                      let invalid_iter_body (function_parameter : unit)
                        : Lwt.t (Error_monad.tzresult Error_monad.__error) :=
                        let '_ := function_parameter in
                        Error_monad.op_gtgteqquestion
                          (serialize_stack_for_error ctxt
                            (Script_typed_ir.descr.aft ibody))
                          (fun function_parameter =>
                            let '(aft, ctxt) := function_parameter in
                            Error_monad.op_gtgtpipequestion
                              (serialize_stack_for_error ctxt rest)
                              (fun function_parameter =>
                                let '(rest, _ctxt) := function_parameter in
                                extensible_type_value)) in
                      Error_monad.trace_eval invalid_iter_body
                        (Error_monad.op_gtgteqquestion
                          (Pervasives.op_atat Lwt.__return
                            (stack_ty_eq ctxt 1 aft rest))
                          (fun function_parameter =>
                            let '(Eq, ctxt) := function_parameter in
                            Error_monad.op_gtgteqquestion
                              (Pervasives.op_atat Lwt.__return
                                (merge_stacks legacy loc ctxt aft rest))
                              (fun function_parameter =>
                                let '(rest, ctxt) := function_parameter in
                                typed ctxt loc (Script_typed_ir.List_iter ibody)
                                  rest)))
                    | Failed {| judgement.Failed.descr := __descr_value |} =>
                      typed ctxt loc
                        (Script_typed_ir.List_iter (__descr_value rest)) rest
                    end)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_EMPTY_SET
          (cons __t_value []) annot, rest), _) =>
        Error_monad.op_gtgteqquestion
          (Pervasives.op_atat Lwt.__return (parse_comparable_ty ctxt __t_value))
          (fun function_parameter =>
            let '(Ex_comparable_ty __t_value, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
              (fun function_parameter =>
                let '(annot, tname) := function_parameter in
                typed ctxt loc (Script_typed_ir.Empty_set __t_value)
                  (Script_typed_ir.Item_t
                    (Script_typed_ir.Set_t __t_value tname) rest annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_ITER (cons body []) annot,
          Script_typed_ir.Item_t (Script_typed_ir.Set_t comp_elt _) rest
            set_annot), _) =>
        Error_monad.op_gtgteqquestion
          (check_kind [ Script_tc_errors.Seq_kind ] body)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (Script_ir_annot.fail_unexpected_annot loc annot)
              (fun function_parameter =>
                let '_ := function_parameter in
                let elt_annot :=
                  Script_ir_annot.gen_access_annot set_annot None
                    Script_ir_annot.default_elt_annot in
                let elt := ty_of_comparable_ty comp_elt in
                Error_monad.op_gtgteqquestion
                  (parse_instr type_logger tc_context ctxt legacy body
                    (Script_typed_ir.Item_t elt rest elt_annot))
                  (fun function_parameter =>
                    let '(judgement, ctxt) := function_parameter in
                    match judgement with
                    | Typed ({| Script_typed_ir.descr.aft := aft |} as ibody) =>
                      let invalid_iter_body (function_parameter : unit)
                        : Lwt.t (Error_monad.tzresult Error_monad.__error) :=
                        let '_ := function_parameter in
                        Error_monad.op_gtgteqquestion
                          (serialize_stack_for_error ctxt
                            (Script_typed_ir.descr.aft ibody))
                          (fun function_parameter =>
                            let '(aft, ctxt) := function_parameter in
                            Error_monad.op_gtgtpipequestion
                              (serialize_stack_for_error ctxt rest)
                              (fun function_parameter =>
                                let '(rest, _ctxt) := function_parameter in
                                extensible_type_value)) in
                      Error_monad.trace_eval invalid_iter_body
                        (Error_monad.op_gtgteqquestion
                          (Pervasives.op_atat Lwt.__return
                            (stack_ty_eq ctxt 1 aft rest))
                          (fun function_parameter =>
                            let '(Eq, ctxt) := function_parameter in
                            Error_monad.op_gtgteqquestion
                              (Pervasives.op_atat Lwt.__return
                                (merge_stacks legacy loc ctxt aft rest))
                              (fun function_parameter =>
                                let '(rest, ctxt) := function_parameter in
                                typed ctxt loc (Script_typed_ir.Set_iter ibody)
                                  rest)))
                    | Failed {| judgement.Failed.descr := __descr_value |} =>
                      typed ctxt loc
                        (Script_typed_ir.Set_iter (__descr_value rest)) rest
                    end)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_MEM [] annot,
          Script_typed_ir.Item_t v
            (Script_typed_ir.Item_t (Script_typed_ir.Set_t elt _) rest _) _), _)
        =>
        let elt := ty_of_comparable_ty elt in
        Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
          (fun function_parameter =>
            let '(annot, tname) := function_parameter in
            Error_monad.op_gtgteqquestion
              (check_item_ty ctxt elt v loc Alpha_context.Script.I_MEM 1 2)
              (fun function_parameter =>
                let '(Eq, _, ctxt) := function_parameter in
                typed ctxt loc Script_typed_ir.Set_mem
                  (Script_typed_ir.Item_t (Script_typed_ir.Bool_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_UPDATE [] annot,
          Script_typed_ir.Item_t v
            (Script_typed_ir.Item_t (Script_typed_ir.Bool_t _)
              (Script_typed_ir.Item_t (Script_typed_ir.Set_t elt tname) rest
                set_annot) _) _), _) =>
        match comparable_ty_of_ty v with
        | None =>
          Error_monad.op_gtgteqquestion (unparse_ty ctxt v)
            (fun function_parameter =>
              let '(v, _ctxt) := function_parameter in
              Error_monad.fail extensible_type_value)
        | Some v =>
          Error_monad.op_gtgteqquestion
            (parse_var_annot loc (Some set_annot) annot)
            (fun annot =>
              Error_monad.op_gtgteqquestion
                (check_item_comparable_ty elt v loc
                  Alpha_context.Script.I_UPDATE 1 3)
                (fun function_parameter =>
                  let '(Eq, elt) := function_parameter in
                  typed ctxt loc Script_typed_ir.Set_update
                    (Script_typed_ir.Item_t (Script_typed_ir.Set_t elt tname)
                      rest annot)))
        end
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SIZE [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Set_t _ _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Set_size
              (Script_typed_ir.Item_t (Script_typed_ir.Nat_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_EMPTY_MAP
          (cons tk (cons tv [])) annot, stack), _) =>
        Error_monad.op_gtgteqquestion
          (Pervasives.op_atat Lwt.__return (parse_comparable_ty ctxt tk))
          (fun function_parameter =>
            let '(Ex_comparable_ty tk, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return (parse_any_ty ctxt legacy tv))
              (fun function_parameter =>
                let '(Ex_ty tv, ctxt) := function_parameter in
                Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
                  (fun function_parameter =>
                    let '(annot, ty_name) := function_parameter in
                    typed ctxt loc (Script_typed_ir.Empty_map tk tv)
                      (Script_typed_ir.Item_t
                        (Script_typed_ir.Map_t tk tv ty_name (has_big_map tv))
                        stack annot))))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_MAP (cons body []) annot,
          Script_typed_ir.Item_t (Script_typed_ir.Map_t ck elt _ _)
            starting_rest _map_annot), _) =>
        let k := ty_of_comparable_ty ck in
        Error_monad.op_gtgteqquestion
          (check_kind [ Script_tc_errors.Seq_kind ] body)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
              (fun function_parameter =>
                let '(ret_annot, ty_name) := function_parameter in
                let k_name :=
                  Script_ir_annot.field_to_var_annot
                    Script_ir_annot.default_key_annot in
                let e_name :=
                  Script_ir_annot.field_to_var_annot
                    Script_ir_annot.default_elt_annot in
                Error_monad.op_gtgteqquestion
                  (parse_instr type_logger tc_context ctxt legacy body
                    (Script_typed_ir.Item_t
                      (Script_typed_ir.Pair_t (k, None, k_name)
                        (elt, None, e_name) None (has_big_map elt))
                      starting_rest None))
                  (fun function_parameter =>
                    let '(judgement, ctxt) := function_parameter in
                    match judgement with
                    |
                      Typed
                        ({|
                          Script_typed_ir.descr.aft := Script_typed_ir.Item_t ret rest _
                            |} as ibody) =>
                      let invalid_map_body (function_parameter : unit)
                        : Lwt.t (Error_monad.tzresult Error_monad.__error) :=
                        let '_ := function_parameter in
                        Error_monad.op_gtgtpipequestion
                          (serialize_stack_for_error ctxt
                            (Script_typed_ir.descr.aft ibody))
                          (fun function_parameter =>
                            let '(aft, _ctxt) := function_parameter in
                            extensible_type_value) in
                      Error_monad.trace_eval invalid_map_body
                        (Error_monad.op_gtgteqquestion
                          (Pervasives.op_atat Lwt.__return
                            (stack_ty_eq ctxt 1 rest starting_rest))
                          (fun function_parameter =>
                            let '(Eq, ctxt) := function_parameter in
                            Error_monad.op_gtgteqquestion
                              (Pervasives.op_atat Lwt.__return
                                (merge_stacks legacy loc ctxt rest starting_rest))
                              (fun function_parameter =>
                                let '(rest, ctxt) := function_parameter in
                                typed ctxt loc (Script_typed_ir.Map_map ibody)
                                  (Script_typed_ir.Item_t
                                    (Script_typed_ir.Map_t ck ret ty_name
                                      (has_big_map ret)) rest ret_annot))))
                    | Typed {| Script_typed_ir.descr.aft := aft |} =>
                      Error_monad.op_gtgteqquestion
                        (serialize_stack_for_error ctxt aft)
                        (fun function_parameter =>
                          let '(aft, _ctxt) := function_parameter in
                          Error_monad.fail extensible_type_value)
                    | Failed _ => Error_monad.fail extensible_type_value
                    end)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_ITER (cons body []) annot,
          Script_typed_ir.Item_t (Script_typed_ir.Map_t comp_elt element_ty _ _)
            rest _map_annot), _) =>
        Error_monad.op_gtgteqquestion
          (check_kind [ Script_tc_errors.Seq_kind ] body)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (Script_ir_annot.fail_unexpected_annot loc annot)
              (fun function_parameter =>
                let '_ := function_parameter in
                let k_name :=
                  Script_ir_annot.field_to_var_annot
                    Script_ir_annot.default_key_annot in
                let e_name :=
                  Script_ir_annot.field_to_var_annot
                    Script_ir_annot.default_elt_annot in
                let key := ty_of_comparable_ty comp_elt in
                Error_monad.op_gtgteqquestion
                  (parse_instr type_logger tc_context ctxt legacy body
                    (Script_typed_ir.Item_t
                      (Script_typed_ir.Pair_t (key, None, k_name)
                        (element_ty, None, e_name) None (has_big_map element_ty))
                      rest None))
                  (fun function_parameter =>
                    let '(judgement, ctxt) := function_parameter in
                    match judgement with
                    | Typed ({| Script_typed_ir.descr.aft := aft |} as ibody) =>
                      let invalid_iter_body (function_parameter : unit)
                        : Lwt.t (Error_monad.tzresult Error_monad.__error) :=
                        let '_ := function_parameter in
                        Error_monad.op_gtgteqquestion
                          (serialize_stack_for_error ctxt
                            (Script_typed_ir.descr.aft ibody))
                          (fun function_parameter =>
                            let '(aft, ctxt) := function_parameter in
                            Error_monad.op_gtgtpipequestion
                              (serialize_stack_for_error ctxt rest)
                              (fun function_parameter =>
                                let '(rest, _ctxt) := function_parameter in
                                extensible_type_value)) in
                      Error_monad.trace_eval invalid_iter_body
                        (Error_monad.op_gtgteqquestion
                          (Pervasives.op_atat Lwt.__return
                            (stack_ty_eq ctxt 1 aft rest))
                          (fun function_parameter =>
                            let '(Eq, ctxt) := function_parameter in
                            Error_monad.op_gtgteqquestion
                              (Pervasives.op_atat Lwt.__return
                                (merge_stacks legacy loc ctxt aft rest))
                              (fun function_parameter =>
                                let '(rest, ctxt) := function_parameter in
                                typed ctxt loc (Script_typed_ir.Map_iter ibody)
                                  rest)))
                    | Failed {| judgement.Failed.descr := __descr_value |} =>
                      typed ctxt loc
                        (Script_typed_ir.Map_iter (__descr_value rest)) rest
                    end)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_MEM [] annot,
          Script_typed_ir.Item_t vk
            (Script_typed_ir.Item_t (Script_typed_ir.Map_t ck _ _ _) rest _) _),
          _) =>
        let k := ty_of_comparable_ty ck in
        Error_monad.op_gtgteqquestion
          (check_item_ty ctxt vk k loc Alpha_context.Script.I_MEM 1 2)
          (fun function_parameter =>
            let '(Eq, _, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
              (fun annot =>
                typed ctxt loc Script_typed_ir.Map_mem
                  (Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_GET [] annot,
          Script_typed_ir.Item_t vk
            (Script_typed_ir.Item_t (Script_typed_ir.Map_t ck elt _ has_big_map)
              rest _) _), _) =>
        let k := ty_of_comparable_ty ck in
        Error_monad.op_gtgteqquestion
          (check_item_ty ctxt vk k loc Alpha_context.Script.I_GET 1 2)
          (fun function_parameter =>
            let '(Eq, _, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
              (fun annot =>
                typed ctxt loc Script_typed_ir.Map_get
                  (Script_typed_ir.Item_t
                    (Script_typed_ir.Option_t elt None has_big_map) rest annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_UPDATE [] annot,
          Script_typed_ir.Item_t vk
            (Script_typed_ir.Item_t (Script_typed_ir.Option_t vv _ _)
              (Script_typed_ir.Item_t
                (Script_typed_ir.Map_t ck v map_name has_big_map) rest map_annot)
              _) _), _) =>
        let k := ty_of_comparable_ty ck in
        Error_monad.op_gtgteqquestion
          (check_item_ty ctxt vk k loc Alpha_context.Script.I_UPDATE 1 3)
          (fun function_parameter =>
            let '(Eq, _, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion
              (check_item_ty ctxt vv v loc Alpha_context.Script.I_UPDATE 2 3)
              (fun function_parameter =>
                let '(Eq, v, ctxt) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (parse_var_annot loc (Some map_annot) annot)
                  (fun annot =>
                    typed ctxt loc Script_typed_ir.Map_update
                      (Script_typed_ir.Item_t
                        (Script_typed_ir.Map_t ck v map_name has_big_map) rest
                        annot))))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SIZE [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Map_t _ _ _ _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Map_size
              (Script_typed_ir.Item_t (Script_typed_ir.Nat_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_EMPTY_BIG_MAP
          (cons tk (cons tv [])) annot, stack), _) =>
        Error_monad.op_gtgteqquestion
          (Pervasives.op_atat Lwt.__return (parse_comparable_ty ctxt tk))
          (fun function_parameter =>
            let '(Ex_comparable_ty tk, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (parse_packable_ty ctxt legacy tv))
              (fun function_parameter =>
                let '(Ex_ty tv, ctxt) := function_parameter in
                Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
                  (fun function_parameter =>
                    let '(annot, ty_name) := function_parameter in
                    typed ctxt loc (Script_typed_ir.Empty_big_map tk tv)
                      (Script_typed_ir.Item_t
                        (Script_typed_ir.Big_map_t tk tv ty_name) stack annot))))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_MEM [] annot,
          Script_typed_ir.Item_t set_key
            (Script_typed_ir.Item_t (Script_typed_ir.Big_map_t map_key _ _) rest
              _) _), _) =>
        let k := ty_of_comparable_ty map_key in
        Error_monad.op_gtgteqquestion
          (check_item_ty ctxt set_key k loc Alpha_context.Script.I_MEM 1 2)
          (fun function_parameter =>
            let '(Eq, _, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
              (fun annot =>
                typed ctxt loc Script_typed_ir.Big_map_mem
                  (Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_GET [] annot,
          Script_typed_ir.Item_t vk
            (Script_typed_ir.Item_t (Script_typed_ir.Big_map_t ck elt _) rest _)
            _), _) =>
        let k := ty_of_comparable_ty ck in
        Error_monad.op_gtgteqquestion
          (check_item_ty ctxt vk k loc Alpha_context.Script.I_GET 1 2)
          (fun function_parameter =>
            let '(Eq, _, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
              (fun annot =>
                typed ctxt loc Script_typed_ir.Big_map_get
                  (Script_typed_ir.Item_t
                    (Script_typed_ir.Option_t elt None (has_big_map elt)) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_UPDATE [] annot,
          Script_typed_ir.Item_t set_key
            (Script_typed_ir.Item_t (Script_typed_ir.Option_t set_value _ _)
              (Script_typed_ir.Item_t
                (Script_typed_ir.Big_map_t map_key map_value map_name) rest
                map_annot) _) _), _) =>
        let k := ty_of_comparable_ty map_key in
        Error_monad.op_gtgteqquestion
          (check_item_ty ctxt set_key k loc Alpha_context.Script.I_UPDATE 1 3)
          (fun function_parameter =>
            let '(Eq, _, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion
              (check_item_ty ctxt set_value map_value loc
                Alpha_context.Script.I_UPDATE 2 3)
              (fun function_parameter =>
                let '(Eq, map_value, ctxt) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (parse_var_annot loc (Some map_annot) annot)
                  (fun annot =>
                    typed ctxt loc Script_typed_ir.Big_map_update
                      (Script_typed_ir.Item_t
                        (Script_typed_ir.Big_map_t map_key map_value map_name)
                        rest annot))))
      | ((Micheline.Seq loc [], stack), _) =>
        typed ctxt loc Script_typed_ir.Nop stack
      | ((Micheline.Seq loc (cons single []), stack), _) =>
        Error_monad.op_gtgteqquestion
          (parse_instr type_logger tc_context ctxt legacy single stack)
          (fun function_parameter =>
            let '(judgement, ctxt) := function_parameter in
            match judgement with
            | Typed ({| Script_typed_ir.descr.aft := aft |} as instr) =>
              let nop :=
                {| Script_typed_ir.descr.loc := loc;
                  Script_typed_ir.descr.bef := aft;
                  Script_typed_ir.descr.aft := aft;
                  Script_typed_ir.descr.instr := Script_typed_ir.Nop |} in
              typed ctxt loc (Script_typed_ir.Seq instr nop) aft
            | Failed {| judgement.Failed.descr := __descr_value |} =>
              let __descr_value {B : Set} (aft : Script_typed_ir.stack_ty B)
                : Script_typed_ir.descr bef B :=
                let nop :=
                  {| Script_typed_ir.descr.loc := loc;
                    Script_typed_ir.descr.bef := aft;
                    Script_typed_ir.descr.aft := aft;
                    Script_typed_ir.descr.instr := Script_typed_ir.Nop |} in
                let __descr_value := __descr_value aft in
                Script_typed_ir.descr.with_instr
                  (Script_typed_ir.Seq __descr_value nop) __descr_value in
              __return ctxt
                (Failed {| judgement.Failed.descr := __descr_value |})
            end)
      | ((Micheline.Seq loc (cons hd tl), stack), _) =>
        Error_monad.op_gtgteqquestion
          (parse_instr type_logger tc_context ctxt legacy hd stack)
          (fun function_parameter =>
            let '(judgement, ctxt) := function_parameter in
            match judgement with
            | Failed _ => Error_monad.fail extensible_type_value
            | Typed ({| Script_typed_ir.descr.aft := middle |} as ihd) =>
              Error_monad.op_gtgteqquestion
                (parse_instr type_logger tc_context ctxt legacy
                  (Micheline.Seq (-1) tl) middle)
                (fun function_parameter =>
                  let '(judgement, ctxt) := function_parameter in
                  match judgement with
                  | Failed {| judgement.Failed.descr := __descr_value |} =>
                    let __descr_value {B : Set}
                      (ret : Script_typed_ir.stack_ty B)
                      : Script_typed_ir.descr bef B :=
                      {| Script_typed_ir.descr.loc := loc;
                        Script_typed_ir.descr.bef := stack;
                        Script_typed_ir.descr.aft := ret;
                        Script_typed_ir.descr.instr :=
                          Script_typed_ir.Seq ihd (__descr_value ret) |} in
                    __return ctxt
                      (Failed {| judgement.Failed.descr := __descr_value |})
                  | Typed itl =>
                    typed ctxt loc (Script_typed_ir.Seq ihd itl)
                      (Script_typed_ir.descr.aft itl)
                  end)
            end)
      |
        ((Micheline.Prim loc Alpha_context.Script.I_IF (cons bt (cons bf []))
          annot,
          (Script_typed_ir.Item_t (Script_typed_ir.Bool_t _) rest _) as bef), _)
        =>
        Error_monad.op_gtgteqquestion
          (check_kind [ Script_tc_errors.Seq_kind ] bt)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (check_kind [ Script_tc_errors.Seq_kind ] bf)
              (fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Script_ir_annot.fail_unexpected_annot loc annot)
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    Error_monad.op_gtgteqquestion
                      (parse_instr type_logger tc_context ctxt legacy bt rest)
                      (fun function_parameter =>
                        let '(btr, ctxt) := function_parameter in
                        Error_monad.op_gtgteqquestion
                          (parse_instr type_logger tc_context ctxt legacy bf
                            rest)
                          (fun function_parameter =>
                            let '(bfr, ctxt) := function_parameter in
                            let branch {B : Set}
                              (ibt : Script_typed_ir.descr __169 B)
                              (ibf : Script_typed_ir.descr __169 B)
                              : Script_typed_ir.descr (bool * __169) B :=
                              {| Script_typed_ir.descr.loc := loc;
                                Script_typed_ir.descr.bef := bef;
                                Script_typed_ir.descr.aft :=
                                  Script_typed_ir.descr.aft ibt;
                                Script_typed_ir.descr.instr :=
                                  Script_typed_ir.If ibt ibf |} in
                            Error_monad.op_gtgteqquestion
                              (merge_branches legacy ctxt loc btr bfr
                                {| branch.branch := branch |})
                              (fun function_parameter =>
                                let '(judgement, ctxt) := function_parameter in
                                __return ctxt judgement))))))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_LOOP (cons body []) annot,
          (Script_typed_ir.Item_t (Script_typed_ir.Bool_t _) rest _stack_annot)
            as stack), _) =>
        Error_monad.op_gtgteqquestion
          (check_kind [ Script_tc_errors.Seq_kind ] body)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (Script_ir_annot.fail_unexpected_annot loc annot)
              (fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.op_gtgteqquestion
                  (parse_instr type_logger tc_context ctxt legacy body rest)
                  (fun function_parameter =>
                    let '(judgement, ctxt) := function_parameter in
                    match judgement with
                    | Typed ibody =>
                      let unmatched_branches (function_parameter : unit)
                        : Lwt.t (Error_monad.tzresult Error_monad.__error) :=
                        let '_ := function_parameter in
                        Error_monad.op_gtgteqquestion
                          (serialize_stack_for_error ctxt
                            (Script_typed_ir.descr.aft ibody))
                          (fun function_parameter =>
                            let '(aft, ctxt) := function_parameter in
                            Error_monad.op_gtgtpipequestion
                              (serialize_stack_for_error ctxt stack)
                              (fun function_parameter =>
                                let '(stack, _ctxt) := function_parameter in
                                extensible_type_value)) in
                      Error_monad.trace_eval unmatched_branches
                        (Error_monad.op_gtgteqquestion
                          (Pervasives.op_atat Lwt.__return
                            (stack_ty_eq ctxt 1
                              (Script_typed_ir.descr.aft ibody) stack))
                          (fun function_parameter =>
                            let '(Eq, ctxt) := function_parameter in
                            Error_monad.op_gtgteqquestion
                              (Pervasives.op_atat Lwt.__return
                                (merge_stacks legacy loc ctxt
                                  (Script_typed_ir.descr.aft ibody) stack))
                              (fun function_parameter =>
                                let '(_stack, ctxt) := function_parameter in
                                typed ctxt loc (Script_typed_ir.Loop ibody) rest)))
                    | Failed {| judgement.Failed.descr := __descr_value |} =>
                      let ibody := __descr_value stack in
                      typed ctxt loc (Script_typed_ir.Loop ibody) rest
                    end)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_LOOP_LEFT (cons body [])
          annot,
          (Script_typed_ir.Item_t
            (Script_typed_ir.Union_t (tl, l_field) (tr, _) _ _) rest union_annot)
            as stack), _) =>
        Error_monad.op_gtgteqquestion
          (check_kind [ Script_tc_errors.Seq_kind ] body)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
              (fun annot =>
                let l_annot :=
                  Script_ir_annot.gen_access_annot union_annot
                    (Some Script_ir_annot.default_left_annot) l_field in
                Error_monad.op_gtgteqquestion
                  (parse_instr type_logger tc_context ctxt legacy body
                    (Script_typed_ir.Item_t tl rest l_annot))
                  (fun function_parameter =>
                    let '(judgement, ctxt) := function_parameter in
                    match judgement with
                    | Typed ibody =>
                      let unmatched_branches (function_parameter : unit)
                        : Lwt.t (Error_monad.tzresult Error_monad.__error) :=
                        let '_ := function_parameter in
                        Error_monad.op_gtgteqquestion
                          (serialize_stack_for_error ctxt
                            (Script_typed_ir.descr.aft ibody))
                          (fun function_parameter =>
                            let '(aft, ctxt) := function_parameter in
                            Error_monad.op_gtgtpipequestion
                              (serialize_stack_for_error ctxt stack)
                              (fun function_parameter =>
                                let '(stack, _ctxt) := function_parameter in
                                extensible_type_value)) in
                      Error_monad.trace_eval unmatched_branches
                        (Error_monad.op_gtgteqquestion
                          (Pervasives.op_atat Lwt.__return
                            (stack_ty_eq ctxt 1
                              (Script_typed_ir.descr.aft ibody) stack))
                          (fun function_parameter =>
                            let '(Eq, ctxt) := function_parameter in
                            Error_monad.op_gtgteqquestion
                              (Pervasives.op_atat Lwt.__return
                                (merge_stacks legacy loc ctxt
                                  (Script_typed_ir.descr.aft ibody) stack))
                              (fun function_parameter =>
                                let '(_stack, ctxt) := function_parameter in
                                typed ctxt loc (Script_typed_ir.Loop_left ibody)
                                  (Script_typed_ir.Item_t tr rest annot))))
                    | Failed {| judgement.Failed.descr := __descr_value |} =>
                      let ibody := __descr_value stack in
                      typed ctxt loc (Script_typed_ir.Loop_left ibody)
                        (Script_typed_ir.Item_t tr rest annot)
                    end)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_LAMBDA
          (cons arg (cons ret (cons code []))) annot, stack), _) =>
        Error_monad.op_gtgteqquestion
          (Pervasives.op_atat Lwt.__return (parse_any_ty ctxt legacy arg))
          (fun function_parameter =>
            let '(Ex_ty arg, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return (parse_any_ty ctxt legacy ret))
              (fun function_parameter =>
                let '(Ex_ty ret, ctxt) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (check_kind [ Script_tc_errors.Seq_kind ] code)
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    Error_monad.op_gtgteqquestion
                      (parse_var_annot loc None annot)
                      (fun annot =>
                        Error_monad.op_gtgteqquestion
                          (parse_returning type_logger Lambda ctxt legacy
                            (arg, Script_ir_annot.default_arg_annot) ret code)
                          (fun function_parameter =>
                            let '(lambda, ctxt) := function_parameter in
                            typed ctxt loc (Script_typed_ir.Lambda lambda)
                              (Script_typed_ir.Item_t
                                (Script_typed_ir.Lambda_t arg ret None) stack
                                annot))))))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_EXEC [] annot,
          Script_typed_ir.Item_t arg
            (Script_typed_ir.Item_t (Script_typed_ir.Lambda_t param ret _) rest
              _) _), _) =>
        Error_monad.op_gtgteqquestion
          (check_item_ty ctxt arg param loc Alpha_context.Script.I_EXEC 1 2)
          (fun function_parameter =>
            let '(Eq, _, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
              (fun annot =>
                typed ctxt loc Script_typed_ir.Exec
                  (Script_typed_ir.Item_t ret rest annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_APPLY [] annot,
          Script_typed_ir.Item_t capture
            (Script_typed_ir.Item_t
              (Script_typed_ir.Lambda_t
                (Script_typed_ir.Pair_t (capture_ty, _, _) (arg_ty, _, _)
                  lam_annot _) ret _) rest _) _), _) =>
        Error_monad.op_gtgteqquestion
          (Pervasives.op_atat Lwt.__return (check_packable false loc capture_ty))
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (check_item_ty ctxt capture capture_ty loc
                Alpha_context.Script.I_APPLY 1 2)
              (fun function_parameter =>
                let '(Eq, capture_ty, ctxt) := function_parameter in
                Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
                  (fun annot =>
                    typed ctxt loc (Script_typed_ir.Apply capture_ty)
                      (Script_typed_ir.Item_t
                        (Script_typed_ir.Lambda_t arg_ty ret lam_annot) rest
                        annot))))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_DIP (cons code []) annot,
          Script_typed_ir.Item_t v rest stack_annot), _) =>
        Error_monad.op_gtgteqquestion
          (Script_ir_annot.fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (check_kind [ Script_tc_errors.Seq_kind ] code)
              (fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.op_gtgteqquestion
                  (parse_instr type_logger (add_dip v stack_annot tc_context)
                    ctxt legacy code rest)
                  (fun function_parameter =>
                    let '(judgement, ctxt) := function_parameter in
                    match judgement with
                    | Typed __descr_value =>
                      typed ctxt loc (Script_typed_ir.Dip __descr_value)
                        (Script_typed_ir.Item_t v
                          (Script_typed_ir.descr.aft __descr_value) stack_annot)
                    | Failed _ => Error_monad.fail extensible_type_value
                    end)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_DIP (cons n (cons code []))
          result_annot, stack), true) =>
        let fix make_proof_argument {tstk : Set}
          (n : Z) (inner_tc_context : tc_context)
          (stk : Script_typed_ir.stack_ty tstk) {struct n}
          : Lwt.t (Error_monad.tzresult (dipn_proof_argument tstk)) :=
          match (((|Compare.Int|).(Compare.S.op_eq) n 0), stk) with
          | (true, rest) =>
            Error_monad.op_gtgteqquestion
              (parse_instr type_logger inner_tc_context ctxt legacy code rest)
              (fun function_parameter =>
                let '(judgement, ctxt) := function_parameter in
                match judgement with
                | Typed __descr_value =>
                  Pervasives.op_atat outer_return
                    (Dipn_proof_argument
                      (Script_typed_ir.Rest, (ctxt, __descr_value),
                        (Script_typed_ir.descr.aft __descr_value)))
                | Failed _ => Error_monad.fail extensible_type_value
                end)
          | (false, Script_typed_ir.Item_t v rest annot) =>
            Error_monad.op_gtgteqquestion
              (make_proof_argument (Pervasives.op_minus n 1)
                (add_dip v annot tc_context) rest)
              (fun function_parameter =>
                let 'Dipn_proof_argument (n', __descr_value, aft') :=
                  function_parameter in
                Pervasives.op_atat outer_return
                  (Dipn_proof_argument
                    ((Script_typed_ir.Prefix n'), __descr_value,
                      (Script_typed_ir.Item_t v aft' annot))))
          | (_, _) =>
            Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
              (fun function_parameter =>
                let '(whole_stack, _ctxt) := function_parameter in
                Error_monad.fail extensible_type_value)
          end in
        Error_monad.op_gtgteqquestion (Lwt.__return (parse_int32 n))
          (fun n =>
            Error_monad.op_gtgteqquestion
              (Script_ir_annot.fail_unexpected_annot loc result_annot)
              (fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.op_gtgteqquestion
                  (make_proof_argument n tc_context stack)
                  (fun function_parameter =>
                    let
                      'Dipn_proof_argument (n', (new_ctxt, __descr_value), aft) :=
                      function_parameter in
                    typed new_ctxt loc (Script_typed_ir.Dipn n n' __descr_value)
                      aft)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_DIP
          (([] | cons _ (cons _ (cons _ _))) as l) _, _), _) =>
        Error_monad.fail extensible_type_value
      |
        ((Micheline.Prim loc Alpha_context.Script.I_FAILWITH [] annot,
          Script_typed_ir.Item_t v _rest _), _) =>
        Error_monad.op_gtgteqquestion
          (Script_ir_annot.fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let '_ := function_parameter in
            let __descr_value {B : Set} (aft : Script_typed_ir.stack_ty B)
              : Script_typed_ir.descr bef B :=
              {| Script_typed_ir.descr.loc := loc;
                Script_typed_ir.descr.bef := stack_ty;
                Script_typed_ir.descr.aft := aft;
                Script_typed_ir.descr.instr := Script_typed_ir.Failwith v |} in
            Error_monad.op_gtgteqquestion
              (log_stack ctxt loc stack_ty Script_typed_ir.Empty_t)
              (fun function_parameter =>
                let '_ := function_parameter in
                __return ctxt
                  (Failed {| judgement.Failed.descr := __descr_value |})))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_ADD [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t tname)
            (Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _) _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Add_timestamp_to_seconds
              (Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t tname) rest
                annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_ADD [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t _)
            (Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t tname) rest _)
            _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Add_seconds_to_timestamp
              (Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t tname) rest
                annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SUB [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t tname)
            (Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _) _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Sub_timestamp_seconds
              (Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t tname) rest
                annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SUB [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t tn2) rest _) _),
          _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Diff_timestamps
                  (Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_CONCAT [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.String_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.String_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Concat_string_pair
                  (Script_typed_ir.Item_t (Script_typed_ir.String_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_CONCAT [] annot,
          Script_typed_ir.Item_t
            (Script_typed_ir.List_t (Script_typed_ir.String_t tname) _ _) rest
            list_annot), _) =>
        Error_monad.op_gtgteqquestion
          (parse_var_annot loc (Some list_annot) annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Concat_string
              (Script_typed_ir.Item_t (Script_typed_ir.String_t tname) rest
                annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SLICE [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t _)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t _)
              (Script_typed_ir.Item_t (Script_typed_ir.String_t tname) rest
                string_annot) _) _), _) =>
        Error_monad.op_gtgteqquestion
          (parse_var_annot loc
            (Some
              (Script_ir_annot.gen_access_annot string_annot None
                Script_ir_annot.default_slice_annot)) annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Slice_string
              (Script_typed_ir.Item_t
                (Script_typed_ir.Option_t (Script_typed_ir.String_t tname) None
                  false) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SIZE [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.String_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.String_size
              (Script_typed_ir.Item_t (Script_typed_ir.Nat_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_CONCAT [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Bytes_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Bytes_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Concat_bytes_pair
                  (Script_typed_ir.Item_t (Script_typed_ir.Bytes_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_CONCAT [] annot,
          Script_typed_ir.Item_t
            (Script_typed_ir.List_t (Script_typed_ir.Bytes_t tname) _ _) rest
            list_annot), _) =>
        Error_monad.op_gtgteqquestion
          (parse_var_annot loc (Some list_annot) annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Concat_bytes
              (Script_typed_ir.Item_t (Script_typed_ir.Bytes_t tname) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SLICE [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t _)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t _)
              (Script_typed_ir.Item_t (Script_typed_ir.Bytes_t tname) rest
                bytes_annot) _) _), _) =>
        Error_monad.op_gtgteqquestion
          (parse_var_annot loc
            (Some
              (Script_ir_annot.gen_access_annot bytes_annot None
                Script_ir_annot.default_slice_annot)) annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Slice_bytes
              (Script_typed_ir.Item_t
                (Script_typed_ir.Option_t (Script_typed_ir.Bytes_t tname) None
                  false) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SIZE [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Bytes_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Bytes_size
              (Script_typed_ir.Item_t (Script_typed_ir.Nat_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_ADD [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Add_tez
                  (Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SUB [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Sub_tez
                  (Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_MUL [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tname)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _) _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Mul_teznat
              (Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tname) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_MUL [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t _)
            (Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tname) rest _) _),
          _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Mul_nattez
              (Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tname) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_OR [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Bool_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Bool_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Or
                  (Script_typed_ir.Item_t (Script_typed_ir.Bool_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_AND [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Bool_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Bool_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.And
                  (Script_typed_ir.Item_t (Script_typed_ir.Bool_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_XOR [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Bool_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Bool_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Xor
                  (Script_typed_ir.Item_t (Script_typed_ir.Bool_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_NOT [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Bool_t tname) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Not
              (Script_typed_ir.Item_t (Script_typed_ir.Bool_t tname) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_ABS [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Abs_int
              (Script_typed_ir.Item_t (Script_typed_ir.Nat_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_ISNAT [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest int_annot), _)
        =>
        Error_monad.op_gtgteqquestion
          (parse_var_annot loc (Some int_annot) annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Is_nat
              (Script_typed_ir.Item_t
                (Script_typed_ir.Option_t (Script_typed_ir.Nat_t None) None
                  false) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_INT [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Int_nat
              (Script_typed_ir.Item_t (Script_typed_ir.Int_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_NEG [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Neg_int
              (Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_NEG [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Neg_nat
              (Script_typed_ir.Item_t (Script_typed_ir.Int_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_ADD [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Int_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Add_intint
                  (Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_ADD [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t tname)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _) _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Add_intnat
              (Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_ADD [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t _)
            (Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Add_natint
              (Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_ADD [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Add_natnat
                  (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SUB [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Int_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Sub_int
                  (Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SUB [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t tname)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _) _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Sub_int
              (Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SUB [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t _)
            (Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Sub_int
              (Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SUB [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun _tname =>
                typed ctxt loc Script_typed_ir.Sub_int
                  (Script_typed_ir.Item_t (Script_typed_ir.Int_t None) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_MUL [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Int_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Mul_intint
                  (Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_MUL [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t tname)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _) _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Mul_intnat
              (Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_MUL [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t _)
            (Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Mul_natint
              (Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_MUL [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Mul_natnat
                  (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_EDIV [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tname)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _) _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Ediv_teznat
              (Script_typed_ir.Item_t
                (Script_typed_ir.Option_t
                  (Script_typed_ir.Pair_t
                    ((Script_typed_ir.Mutez_t tname), None, None)
                    ((Script_typed_ir.Mutez_t tname), None, None) None false)
                  None false) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_EDIV [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Ediv_tez
                  (Script_typed_ir.Item_t
                    (Script_typed_ir.Option_t
                      (Script_typed_ir.Pair_t
                        ((Script_typed_ir.Nat_t None), None, None)
                        ((Script_typed_ir.Mutez_t tname), None, None) None false)
                      None false) rest annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_EDIV [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Int_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Ediv_intint
                  (Script_typed_ir.Item_t
                    (Script_typed_ir.Option_t
                      (Script_typed_ir.Pair_t
                        ((Script_typed_ir.Int_t tname), None, None)
                        ((Script_typed_ir.Nat_t None), None, None) None false)
                      None false) rest annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_EDIV [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t tname)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _) _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Ediv_intnat
              (Script_typed_ir.Item_t
                (Script_typed_ir.Option_t
                  (Script_typed_ir.Pair_t
                    ((Script_typed_ir.Int_t tname), None, None)
                    ((Script_typed_ir.Nat_t None), None, None) None false) None
                  false) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_EDIV [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname)
            (Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _) _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Ediv_natint
              (Script_typed_ir.Item_t
                (Script_typed_ir.Option_t
                  (Script_typed_ir.Pair_t
                    ((Script_typed_ir.Int_t None), None, None)
                    ((Script_typed_ir.Nat_t tname), None, None) None false) None
                  false) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_EDIV [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Ediv_natnat
                  (Script_typed_ir.Item_t
                    (Script_typed_ir.Option_t
                      (Script_typed_ir.Pair_t
                        ((Script_typed_ir.Nat_t tname), None, None)
                        ((Script_typed_ir.Nat_t tname), None, None) None false)
                      None false) rest annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_LSL [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Lsl_nat
                  (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_LSR [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Lsr_nat
                  (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_OR [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Or_nat
                  (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_AND [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.And_nat
                  (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_AND [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t _)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.And_int_nat
              (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_XOR [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
            (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Script_ir_annot.merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Script_typed_ir.Xor_nat
                  (Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_NOT [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Not_int
              (Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_NOT [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Not_nat
              (Script_typed_ir.Item_t (Script_typed_ir.Int_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_COMPARE [] annot,
          Script_typed_ir.Item_t t1 (Script_typed_ir.Item_t t2 rest _) _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (check_item_ty ctxt t1 t2 loc Alpha_context.Script.I_COMPARE 1 2)
              (fun function_parameter =>
                let '(Eq, __t_value, ctxt) := function_parameter in
                match comparable_ty_of_ty __t_value with
                | None =>
                  Error_monad.op_gtgteqquestion
                    (Lwt.__return (serialize_ty_for_error ctxt __t_value))
                    (fun function_parameter =>
                      let '(__t_value, _ctxt) := function_parameter in
                      Error_monad.fail extensible_type_value)
                | Some key =>
                  typed ctxt loc (Script_typed_ir.Compare key)
                    (Script_typed_ir.Item_t (Script_typed_ir.Int_t None) rest
                      annot)
                end))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_EQ [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Eq
              (Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_NEQ [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Neq
              (Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_LT [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Lt
              (Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_GT [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Gt
              (Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_LE [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Le
              (Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_GE [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Ge
              (Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_CAST (cons cast_t []) annot,
          Script_typed_ir.Item_t __t_value stack item_annot), _) =>
        Error_monad.op_gtgteqquestion
          (parse_var_annot loc (Some item_annot) annot)
          (fun annot =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return (parse_any_ty ctxt legacy cast_t))
              (fun function_parameter =>
                let '(Ex_ty cast_t, ctxt) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Pervasives.op_atat Lwt.__return (ty_eq ctxt cast_t __t_value))
                  (fun function_parameter =>
                    let '(Eq, ctxt) := function_parameter in
                    Error_monad.op_gtgteqquestion
                      (Pervasives.op_atat Lwt.__return
                        (merge_types legacy ctxt loc cast_t __t_value))
                      (fun function_parameter =>
                        let '(_, ctxt) := function_parameter in
                        typed ctxt loc Script_typed_ir.Nop
                          (Script_typed_ir.Item_t cast_t stack annot)))))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_RENAME [] annot,
          Script_typed_ir.Item_t __t_value stack _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Nop
              (Script_typed_ir.Item_t __t_value stack annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_PACK [] annot,
          Script_typed_ir.Item_t __t_value rest unpacked_annot), _) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (check_packable true loc __t_value))
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgteqquestion
              (parse_var_annot loc
                (Some
                  (Script_ir_annot.gen_access_annot unpacked_annot None
                    Script_ir_annot.default_pack_annot)) annot)
              (fun annot =>
                typed ctxt loc (Script_typed_ir.Pack __t_value)
                  (Script_typed_ir.Item_t (Script_typed_ir.Bytes_t None) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_UNPACK (cons ty []) annot,
          Script_typed_ir.Item_t (Script_typed_ir.Bytes_t _) rest packed_annot),
          _) =>
        Error_monad.op_gtgteqquestion
          (Pervasives.op_atat Lwt.__return (parse_packable_ty ctxt legacy ty))
          (fun function_parameter =>
            let '(Ex_ty __t_value, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
              (fun function_parameter =>
                let '(annot, ty_name) := function_parameter in
                let annot :=
                  Script_ir_annot.default_annot
                    (Script_ir_annot.gen_access_annot packed_annot None
                      Script_ir_annot.default_unpack_annot) annot in
                typed ctxt loc (Script_typed_ir.Unpack __t_value)
                  (Script_typed_ir.Item_t
                    (Script_typed_ir.Option_t __t_value ty_name false) rest
                    annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_ADDRESS [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Contract_t _ _) rest
            contract_annot), _) =>
        Error_monad.op_gtgteqquestion
          (parse_var_annot loc
            (Some
              (Script_ir_annot.gen_access_annot contract_annot None
                Script_ir_annot.default_addr_annot)) annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Address
              (Script_typed_ir.Item_t (Script_typed_ir.Address_t None) rest
                annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_CONTRACT (cons ty []) annot,
          Script_typed_ir.Item_t (Script_typed_ir.Address_t _) rest addr_annot),
          _) =>
        Error_monad.op_gtgteqquestion
          (Pervasives.op_atat Lwt.__return (parse_parameter_ty ctxt legacy ty))
          (fun function_parameter =>
            let '(Ex_ty __t_value, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion
              (parse_entrypoint_annot loc
                (Some
                  (Script_ir_annot.gen_access_annot addr_annot None
                    Script_ir_annot.default_contract_annot)) annot)
              (fun function_parameter =>
                let '(annot, entrypoint) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Pervasives.op_atat Lwt.__return
                    match entrypoint with
                    | None => Pervasives.Ok "default"
                    | Some (Field_annot "default") =>
                      Error_monad.__error_value extensible_type_value
                    | Some (Field_annot entrypoint) =>
                      if
                        (|Compare.Int|).(Compare.S.op_gt)
                          (String.length entrypoint) 31 then
                        Error_monad.__error_value extensible_type_value
                      else
                        Pervasives.Ok entrypoint
                    end)
                  (fun entrypoint =>
                    typed ctxt loc
                      (Script_typed_ir.Contract __t_value entrypoint)
                      (Script_typed_ir.Item_t
                        (Script_typed_ir.Option_t
                          (Script_typed_ir.Contract_t __t_value None) None false)
                        rest annot))))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_TRANSFER_TOKENS [] annot,
          Script_typed_ir.Item_t p
            (Script_typed_ir.Item_t (Script_typed_ir.Mutez_t _)
              (Script_typed_ir.Item_t (Script_typed_ir.Contract_t cp _) rest _)
              _) _), _) =>
        Error_monad.op_gtgteqquestion
          (check_item_ty ctxt p cp loc Alpha_context.Script.I_TRANSFER_TOKENS 1
            4)
          (fun function_parameter =>
            let '(Eq, _, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
              (fun annot =>
                typed ctxt loc Script_typed_ir.Transfer_tokens
                  (Script_typed_ir.Item_t (Script_typed_ir.Operation_t None)
                    rest annot)))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SET_DELEGATE [] annot,
          Script_typed_ir.Item_t
            (Script_typed_ir.Option_t (Script_typed_ir.Key_hash_t _) _ _) rest _),
          _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Set_delegate
              (Script_typed_ir.Item_t (Script_typed_ir.Operation_t None) rest
                annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_CREATE_ACCOUNT [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Key_hash_t _)
            (Script_typed_ir.Item_t
              (Script_typed_ir.Option_t (Script_typed_ir.Key_hash_t _) _ _)
              (Script_typed_ir.Item_t (Script_typed_ir.Bool_t _)
                (Script_typed_ir.Item_t (Script_typed_ir.Mutez_t _) rest _) _) _)
            _), _) =>
        if legacy then
          Error_monad.op_gtgteqquestion (parse_two_var_annot loc annot)
            (fun function_parameter =>
              let '(op_annot, addr_annot) := function_parameter in
              typed ctxt loc Script_typed_ir.Create_account
                (Script_typed_ir.Item_t (Script_typed_ir.Operation_t None)
                  (Script_typed_ir.Item_t (Script_typed_ir.Address_t None) rest
                    addr_annot) op_annot))
        else
          Error_monad.fail extensible_type_value
      |
        ((Micheline.Prim loc Alpha_context.Script.I_IMPLICIT_ACCOUNT [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Key_hash_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Implicit_account
              (Script_typed_ir.Item_t
                (Script_typed_ir.Contract_t (Script_typed_ir.Unit_t None) None)
                rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_CREATE_CONTRACT
          (cons ((Micheline.Seq _ _) as code) []) annot,
          Script_typed_ir.Item_t (Script_typed_ir.Key_hash_t _)
            (Script_typed_ir.Item_t
              (Script_typed_ir.Option_t (Script_typed_ir.Key_hash_t _) _ _)
              (Script_typed_ir.Item_t (Script_typed_ir.Bool_t _)
                (Script_typed_ir.Item_t (Script_typed_ir.Bool_t _)
                  (Script_typed_ir.Item_t (Script_typed_ir.Mutez_t _)
                    (Script_typed_ir.Item_t ginit rest _) _) _) _) _) _), _) =>
        if legacy then
          Error_monad.op_gtgteqquestion (parse_two_var_annot loc annot)
            (fun function_parameter =>
              let '(op_annot, addr_annot) := function_parameter in
              let cannonical_code :=
                Pervasives.op_atat Pervasives.fst
                  (Micheline.extract_locations code) in
              Error_monad.op_gtgteqquestion
                (Pervasives.op_atat Lwt.__return
                  (parse_toplevel legacy cannonical_code))
                (fun function_parameter =>
                  let '(arg_type, storage_type, code_field, root_name) :=
                    function_parameter in
                  Error_monad.op_gtgteqquestion
                    (Error_monad.trace extensible_type_value
                      (Pervasives.op_atat Lwt.__return
                        (parse_parameter_ty ctxt legacy arg_type)))
                    (fun function_parameter =>
                      let '(Ex_ty arg_type, ctxt) := function_parameter in
                      Error_monad.op_gtgteqquestion
                        (if legacy then
                          Error_monad.__return tt
                        else
                          Lwt.__return
                            (well_formed_entrypoints arg_type root_name))
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          Error_monad.op_gtgteqquestion
                            (Error_monad.trace extensible_type_value
                              (Pervasives.op_atat Lwt.__return
                                (parse_storage_ty ctxt legacy storage_type)))
                            (fun function_parameter =>
                              let '(Ex_ty storage_type, ctxt) :=
                                function_parameter in
                              let arg_annot :=
                                Script_ir_annot.default_annot
                                  Script_ir_annot.default_param_annot
                                  (Script_ir_annot.type_to_var_annot
                                    (name_of_ty arg_type)) in
                              let storage_annot :=
                                Script_ir_annot.default_annot
                                  Script_ir_annot.default_storage_annot
                                  (Script_ir_annot.type_to_var_annot
                                    (name_of_ty storage_type)) in
                              let arg_type_full :=
                                Script_typed_ir.Pair_t
                                  (arg_type, None, arg_annot)
                                  (storage_type, None, storage_annot) None
                                  (Pervasives.op_pipepipe (has_big_map arg_type)
                                    (has_big_map storage_type)) in
                              let ret_type_full :=
                                Script_typed_ir.Pair_t
                                  ((Script_typed_ir.List_t
                                    (Script_typed_ir.Operation_t None) None
                                    false), None, None)
                                  (storage_type, None, None) None
                                  (has_big_map storage_type) in
                              Error_monad.op_gtgteqquestion
                                (Error_monad.trace extensible_type_value
                                  (parse_returning type_logger
                                    (Toplevel
                                      {|
                                        tc_context.Toplevel.storage_type :=
                                          storage_type;
                                        tc_context.Toplevel.param_type :=
                                          arg_type;
                                        tc_context.Toplevel.root_name :=
                                          root_name;
                                        tc_context.Toplevel.legacy_create_contract_literal :=
                                          true |}) ctxt legacy
                                    (arg_type_full, None) ret_type_full
                                    code_field))
                                (fun function_parameter =>
                                  let
                                    '((Script_typed_ir.Lam {|
                                      Script_typed_ir.descr.bef :=
                                        Script_typed_ir.Item_t arg
                                          Script_typed_ir.Empty_t
                                          _;
                                        Script_typed_ir.descr.aft :=
                                          Script_typed_ir.Item_t
                                            ret
                                            Script_typed_ir.Empty_t
                                            _
                                        |} _) as lambda, ctxt) :=
                                    function_parameter in
                                  Error_monad.op_gtgteqquestion
                                    (Pervasives.op_atat Lwt.__return
                                      (ty_eq ctxt arg arg_type_full))
                                    (fun function_parameter =>
                                      let '(Eq, ctxt) := function_parameter in
                                      Error_monad.op_gtgteqquestion
                                        (Pervasives.op_atat Lwt.__return
                                          (merge_types legacy ctxt loc arg
                                            arg_type_full))
                                        (fun function_parameter =>
                                          let '(_, ctxt) := function_parameter
                                            in
                                          Error_monad.op_gtgteqquestion
                                            (Pervasives.op_atat Lwt.__return
                                              (ty_eq ctxt ret ret_type_full))
                                            (fun function_parameter =>
                                              let '(Eq, ctxt) :=
                                                function_parameter in
                                              Error_monad.op_gtgteqquestion
                                                (Pervasives.op_atat Lwt.__return
                                                  (merge_types legacy ctxt loc
                                                    ret ret_type_full))
                                                (fun function_parameter =>
                                                  let '(_, ctxt) :=
                                                    function_parameter in
                                                  Error_monad.op_gtgteqquestion
                                                    (Pervasives.op_atat
                                                      Lwt.__return
                                                      (ty_eq ctxt storage_type
                                                        ginit))
                                                    (fun function_parameter =>
                                                      let '(Eq, ctxt) :=
                                                        function_parameter in
                                                      Error_monad.op_gtgteqquestion
                                                        (Pervasives.op_atat
                                                          Lwt.__return
                                                          (merge_types legacy
                                                            ctxt loc
                                                            storage_type ginit))
                                                        (fun function_parameter
                                                          =>
                                                          let '(_, ctxt) :=
                                                            function_parameter
                                                            in
                                                          typed ctxt loc
                                                            (Script_typed_ir.Create_contract
                                                              storage_type
                                                              arg_type lambda
                                                              root_name)
                                                            (Script_typed_ir.Item_t
                                                              (Script_typed_ir.Operation_t
                                                                None)
                                                              (Script_typed_ir.Item_t
                                                                (Script_typed_ir.Address_t
                                                                  None) rest
                                                                addr_annot)
                                                              op_annot)))))))))))))
        else
          Error_monad.fail extensible_type_value
      |
        ((Micheline.Prim loc Alpha_context.Script.I_CREATE_CONTRACT
          (cons ((Micheline.Seq _ _) as code) []) annot,
          Script_typed_ir.Item_t
            (Script_typed_ir.Option_t (Script_typed_ir.Key_hash_t _) _ _)
            (Script_typed_ir.Item_t (Script_typed_ir.Mutez_t _)
              (Script_typed_ir.Item_t ginit rest _) _) _), _) =>
        Error_monad.op_gtgteqquestion (parse_two_var_annot loc annot)
          (fun function_parameter =>
            let '(op_annot, addr_annot) := function_parameter in
            let cannonical_code :=
              Pervasives.op_atat Pervasives.fst
                (Micheline.extract_locations code) in
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (parse_toplevel legacy cannonical_code))
              (fun function_parameter =>
                let '(arg_type, storage_type, code_field, root_name) :=
                  function_parameter in
                Error_monad.op_gtgteqquestion
                  (Error_monad.trace extensible_type_value
                    (Pervasives.op_atat Lwt.__return
                      (parse_parameter_ty ctxt legacy arg_type)))
                  (fun function_parameter =>
                    let '(Ex_ty arg_type, ctxt) := function_parameter in
                    Error_monad.op_gtgteqquestion
                      (if legacy then
                        Error_monad.__return tt
                      else
                        Lwt.__return
                          (well_formed_entrypoints arg_type root_name))
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        Error_monad.op_gtgteqquestion
                          (Error_monad.trace extensible_type_value
                            (Pervasives.op_atat Lwt.__return
                              (parse_storage_ty ctxt legacy storage_type)))
                          (fun function_parameter =>
                            let '(Ex_ty storage_type, ctxt) :=
                              function_parameter in
                            let arg_annot :=
                              Script_ir_annot.default_annot
                                Script_ir_annot.default_param_annot
                                (Script_ir_annot.type_to_var_annot
                                  (name_of_ty arg_type)) in
                            let storage_annot :=
                              Script_ir_annot.default_annot
                                Script_ir_annot.default_storage_annot
                                (Script_ir_annot.type_to_var_annot
                                  (name_of_ty storage_type)) in
                            let arg_type_full :=
                              Script_typed_ir.Pair_t (arg_type, None, arg_annot)
                                (storage_type, None, storage_annot) None
                                (Pervasives.op_pipepipe (has_big_map arg_type)
                                  (has_big_map storage_type)) in
                            let ret_type_full :=
                              Script_typed_ir.Pair_t
                                ((Script_typed_ir.List_t
                                  (Script_typed_ir.Operation_t None) None false),
                                  None, None) (storage_type, None, None) None
                                (has_big_map storage_type) in
                            Error_monad.op_gtgteqquestion
                              (Error_monad.trace extensible_type_value
                                (parse_returning type_logger
                                  (Toplevel
                                    {|
                                      tc_context.Toplevel.storage_type :=
                                        storage_type;
                                      tc_context.Toplevel.param_type := arg_type;
                                      tc_context.Toplevel.root_name := root_name;
                                      tc_context.Toplevel.legacy_create_contract_literal :=
                                        false |}) ctxt legacy
                                  (arg_type_full, None) ret_type_full code_field))
                              (fun function_parameter =>
                                let
                                  '((Script_typed_ir.Lam {|
                                    Script_typed_ir.descr.bef :=
                                      Script_typed_ir.Item_t arg
                                        Script_typed_ir.Empty_t
                                        _;
                                      Script_typed_ir.descr.aft :=
                                        Script_typed_ir.Item_t
                                          ret
                                          Script_typed_ir.Empty_t
                                          _
                                      |} _) as lambda, ctxt) :=
                                  function_parameter in
                                Error_monad.op_gtgteqquestion
                                  (Pervasives.op_atat Lwt.__return
                                    (ty_eq ctxt arg arg_type_full))
                                  (fun function_parameter =>
                                    let '(Eq, ctxt) := function_parameter in
                                    Error_monad.op_gtgteqquestion
                                      (Pervasives.op_atat Lwt.__return
                                        (merge_types legacy ctxt loc arg
                                          arg_type_full))
                                      (fun function_parameter =>
                                        let '(_, ctxt) := function_parameter in
                                        Error_monad.op_gtgteqquestion
                                          (Pervasives.op_atat Lwt.__return
                                            (ty_eq ctxt ret ret_type_full))
                                          (fun function_parameter =>
                                            let '(Eq, ctxt) :=
                                              function_parameter in
                                            Error_monad.op_gtgteqquestion
                                              (Pervasives.op_atat Lwt.__return
                                                (merge_types legacy ctxt loc ret
                                                  ret_type_full))
                                              (fun function_parameter =>
                                                let '(_, ctxt) :=
                                                  function_parameter in
                                                Error_monad.op_gtgteqquestion
                                                  (Pervasives.op_atat
                                                    Lwt.__return
                                                    (ty_eq ctxt storage_type
                                                      ginit))
                                                  (fun function_parameter =>
                                                    let '(Eq, ctxt) :=
                                                      function_parameter in
                                                    Error_monad.op_gtgteqquestion
                                                      (Pervasives.op_atat
                                                        Lwt.__return
                                                        (merge_types legacy ctxt
                                                          loc storage_type ginit))
                                                      (fun function_parameter =>
                                                        let '(_, ctxt) :=
                                                          function_parameter in
                                                        typed ctxt loc
                                                          (Script_typed_ir.Create_contract_2
                                                            storage_type
                                                            arg_type lambda
                                                            root_name)
                                                          (Script_typed_ir.Item_t
                                                            (Script_typed_ir.Operation_t
                                                              None)
                                                            (Script_typed_ir.Item_t
                                                              (Script_typed_ir.Address_t
                                                                None) rest
                                                              addr_annot)
                                                            op_annot)))))))))))))
      | ((Micheline.Prim loc Alpha_context.Script.I_NOW [] annot, stack), _) =>
        Error_monad.op_gtgteqquestion
          (parse_var_annot loc (Some Script_ir_annot.default_now_annot) annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Now
              (Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t None) stack
                annot))
      | ((Micheline.Prim loc Alpha_context.Script.I_AMOUNT [] annot, stack), _)
        =>
        Error_monad.op_gtgteqquestion
          (parse_var_annot loc (Some Script_ir_annot.default_amount_annot) annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Amount
              (Script_typed_ir.Item_t (Script_typed_ir.Mutez_t None) stack annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_CHAIN_ID [] annot, stack), _)
        =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.ChainId
              (Script_typed_ir.Item_t (Script_typed_ir.Chain_id_t None) stack
                annot))
      | ((Micheline.Prim loc Alpha_context.Script.I_BALANCE [] annot, stack), _)
        =>
        Error_monad.op_gtgteqquestion
          (parse_var_annot loc (Some Script_ir_annot.default_balance_annot)
            annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Balance
              (Script_typed_ir.Item_t (Script_typed_ir.Mutez_t None) stack annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_HASH_KEY [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Key_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Hash_key
              (Script_typed_ir.Item_t (Script_typed_ir.Key_hash_t None) rest
                annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_CHECK_SIGNATURE [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Key_t _)
            (Script_typed_ir.Item_t (Script_typed_ir.Signature_t _)
              (Script_typed_ir.Item_t (Script_typed_ir.Bytes_t _) rest _) _) _),
          _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Check_signature
              (Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_BLAKE2B [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Bytes_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Blake2b
              (Script_typed_ir.Item_t (Script_typed_ir.Bytes_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SHA256 [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Bytes_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Sha256
              (Script_typed_ir.Item_t (Script_typed_ir.Bytes_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_SHA512 [] annot,
          Script_typed_ir.Item_t (Script_typed_ir.Bytes_t _) rest _), _) =>
        Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Sha512
              (Script_typed_ir.Item_t (Script_typed_ir.Bytes_t None) rest annot))
      |
        ((Micheline.Prim loc Alpha_context.Script.I_STEPS_TO_QUOTA [] annot,
          stack), _) =>
        if legacy then
          Error_monad.op_gtgteqquestion
            (parse_var_annot loc (Some Script_ir_annot.default_steps_annot)
              annot)
            (fun annot =>
              typed ctxt loc Script_typed_ir.Steps_to_quota
                (Script_typed_ir.Item_t (Script_typed_ir.Nat_t None) stack annot))
        else
          Error_monad.fail extensible_type_value
      | ((Micheline.Prim loc Alpha_context.Script.I_SOURCE [] annot, stack), _)
        =>
        Error_monad.op_gtgteqquestion
          (parse_var_annot loc (Some Script_ir_annot.default_source_annot) annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Source
              (Script_typed_ir.Item_t (Script_typed_ir.Address_t None) stack
                annot))
      | ((Micheline.Prim loc Alpha_context.Script.I_SENDER [] annot, stack), _)
        =>
        Error_monad.op_gtgteqquestion
          (parse_var_annot loc (Some Script_ir_annot.default_sender_annot) annot)
          (fun annot =>
            typed ctxt loc Script_typed_ir.Sender
              (Script_typed_ir.Item_t (Script_typed_ir.Address_t None) stack
                annot))
      | ((Micheline.Prim loc Alpha_context.Script.I_SELF [] annot, stack), _) =>
        Error_monad.op_gtgteqquestion
          (parse_entrypoint_annot loc (Some Script_ir_annot.default_self_annot)
            annot)
          (fun function_parameter =>
            let '(annot, entrypoint) := function_parameter in
            let entrypoint :=
              Option.unopt_map
                (fun function_parameter =>
                  let 'Field_annot annot := function_parameter in
                  annot) "default" entrypoint in
            let fix get_toplevel_type (function_parameter : tc_context)
              {struct function_parameter}
              : Lwt.t
                (Error_monad.tzresult (judgement bef * Alpha_context.context)) :=
              match function_parameter with
              | Lambda => Error_monad.fail extensible_type_value
              | Dip _ prev => get_toplevel_type prev
              |
                Toplevel {|
                  tc_context.Toplevel.param_type := param_type;
                    tc_context.Toplevel.root_name := root_name;
                    tc_context.Toplevel.legacy_create_contract_literal := false
                    |} =>
                Error_monad.op_gtgteqquestion
                  (Lwt.__return
                    (find_entrypoint param_type root_name entrypoint))
                  (fun function_parameter =>
                    let '(_, Ex_ty param_type) := function_parameter in
                    typed ctxt loc (Script_typed_ir.Self param_type entrypoint)
                      (Script_typed_ir.Item_t
                        (Script_typed_ir.Contract_t param_type None) stack annot))
              |
                Toplevel {|
                  tc_context.Toplevel.param_type := param_type;
                    tc_context.Toplevel.root_name := _;
                    tc_context.Toplevel.legacy_create_contract_literal := true
                    |} =>
                typed ctxt loc (Script_typed_ir.Self param_type "default")
                  (Script_typed_ir.Item_t
                    (Script_typed_ir.Contract_t param_type None) stack annot)
              end in
            get_toplevel_type tc_context)
      |
        ((Micheline.Prim loc
          ((Alpha_context.Script.I_DUP | Alpha_context.Script.I_SWAP |
          Alpha_context.Script.I_SOME | Alpha_context.Script.I_UNIT |
          Alpha_context.Script.I_PAIR | Alpha_context.Script.I_CAR |
          Alpha_context.Script.I_CDR | Alpha_context.Script.I_CONS |
          Alpha_context.Script.I_CONCAT | Alpha_context.Script.I_SLICE |
          Alpha_context.Script.I_MEM | Alpha_context.Script.I_UPDATE |
          Alpha_context.Script.I_MAP | Alpha_context.Script.I_GET |
          Alpha_context.Script.I_EXEC | Alpha_context.Script.I_FAILWITH |
          Alpha_context.Script.I_SIZE | Alpha_context.Script.I_ADD |
          Alpha_context.Script.I_SUB | Alpha_context.Script.I_MUL |
          Alpha_context.Script.I_EDIV | Alpha_context.Script.I_OR |
          Alpha_context.Script.I_AND | Alpha_context.Script.I_XOR |
          Alpha_context.Script.I_NOT | Alpha_context.Script.I_ABS |
          Alpha_context.Script.I_NEG | Alpha_context.Script.I_LSL |
          Alpha_context.Script.I_LSR | Alpha_context.Script.I_COMPARE |
          Alpha_context.Script.I_EQ | Alpha_context.Script.I_NEQ |
          Alpha_context.Script.I_LT | Alpha_context.Script.I_GT |
          Alpha_context.Script.I_LE | Alpha_context.Script.I_GE |
          Alpha_context.Script.I_TRANSFER_TOKENS |
          Alpha_context.Script.I_CREATE_ACCOUNT |
          Alpha_context.Script.I_SET_DELEGATE | Alpha_context.Script.I_NOW |
          Alpha_context.Script.I_IMPLICIT_ACCOUNT |
          Alpha_context.Script.I_AMOUNT | Alpha_context.Script.I_BALANCE |
          Alpha_context.Script.I_CHECK_SIGNATURE |
          Alpha_context.Script.I_HASH_KEY | Alpha_context.Script.I_SOURCE |
          Alpha_context.Script.I_SENDER | Alpha_context.Script.I_BLAKE2B |
          Alpha_context.Script.I_SHA256 | Alpha_context.Script.I_SHA512 |
          Alpha_context.Script.I_STEPS_TO_QUOTA | Alpha_context.Script.I_ADDRESS)
            as name) ((cons _ _) as l) _, _), _) =>
        Error_monad.fail extensible_type_value
      |
        ((Micheline.Prim loc
          ((Alpha_context.Script.I_NONE | Alpha_context.Script.I_LEFT |
          Alpha_context.Script.I_RIGHT | Alpha_context.Script.I_NIL |
          Alpha_context.Script.I_MAP | Alpha_context.Script.I_ITER |
          Alpha_context.Script.I_EMPTY_SET | Alpha_context.Script.I_DIP |
          Alpha_context.Script.I_LOOP | Alpha_context.Script.I_LOOP_LEFT |
          Alpha_context.Script.I_CONTRACT) as name)
          (([] | cons _ (cons _ _)) as l) _, _), _) =>
        Error_monad.fail extensible_type_value
      |
        ((Micheline.Prim loc
          ((Alpha_context.Script.I_PUSH | Alpha_context.Script.I_IF_NONE |
          Alpha_context.Script.I_IF_LEFT | Alpha_context.Script.I_IF_CONS |
          Alpha_context.Script.I_EMPTY_MAP | Alpha_context.Script.I_IF) as name)
          (([] | cons _ [] | cons _ (cons _ (cons _ _))) as l) _, _), _) =>
        Error_monad.fail extensible_type_value
      |
        ((Micheline.Prim loc Alpha_context.Script.I_LAMBDA
          (([] | cons _ [] | cons _ (cons _ (cons _ (cons _ _)))) as l) _, _), _)
        => Error_monad.fail extensible_type_value
      |
        ((Micheline.Prim loc
          ((Alpha_context.Script.I_ADD | Alpha_context.Script.I_SUB |
          Alpha_context.Script.I_MUL | Alpha_context.Script.I_EDIV |
          Alpha_context.Script.I_AND | Alpha_context.Script.I_OR |
          Alpha_context.Script.I_XOR | Alpha_context.Script.I_LSL |
          Alpha_context.Script.I_LSR) as name) [] _,
          Script_typed_ir.Item_t ta (Script_typed_ir.Item_t tb _ _) _), _) =>
        Error_monad.op_gtgteqquestion
          (Pervasives.op_atat Lwt.__return (serialize_ty_for_error ctxt ta))
          (fun function_parameter =>
            let '(ta, ctxt) := function_parameter in
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return (serialize_ty_for_error ctxt tb))
              (fun function_parameter =>
                let '(tb, _ctxt) := function_parameter in
                Error_monad.fail extensible_type_value))
      |
        ((Micheline.Prim loc
          ((Alpha_context.Script.I_NEG | Alpha_context.Script.I_ABS |
          Alpha_context.Script.I_NOT | Alpha_context.Script.I_CONCAT |
          Alpha_context.Script.I_SIZE | Alpha_context.Script.I_EQ |
          Alpha_context.Script.I_NEQ | Alpha_context.Script.I_LT |
          Alpha_context.Script.I_GT | Alpha_context.Script.I_LE |
          Alpha_context.Script.I_GE) as name) [] _,
          Script_typed_ir.Item_t __t_value _ _), _) =>
        Error_monad.op_gtgteqquestion
          (Pervasives.op_atat Lwt.__return
            (serialize_ty_for_error ctxt __t_value))
          (fun function_parameter =>
            let '(__t_value, _ctxt) := function_parameter in
            Error_monad.fail extensible_type_value)
      |
        ((Micheline.Prim loc
          ((Alpha_context.Script.I_UPDATE | Alpha_context.Script.I_SLICE) as
            name) [] _, stack), _) =>
        Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            let '(stack, _ctxt) := function_parameter in
            Error_monad.fail extensible_type_value)
      |
        ((Micheline.Prim loc Alpha_context.Script.I_CREATE_CONTRACT _ _, stack),
          _) =>
        Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            let '(stack, _ctxt) := function_parameter in
            Error_monad.fail extensible_type_value)
      |
        ((Micheline.Prim loc Alpha_context.Script.I_CREATE_ACCOUNT [] _, stack),
          _) =>
        Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            let '(stack, _ctxt) := function_parameter in
            Error_monad.fail extensible_type_value)
      |
        ((Micheline.Prim loc Alpha_context.Script.I_TRANSFER_TOKENS [] _, stack),
          _) =>
        Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            let '(stack, _ctxt) := function_parameter in
            Error_monad.fail extensible_type_value)
      |
        ((Micheline.Prim loc
          ((Alpha_context.Script.I_DROP | Alpha_context.Script.I_DUP |
          Alpha_context.Script.I_CAR | Alpha_context.Script.I_CDR |
          Alpha_context.Script.I_SOME | Alpha_context.Script.I_BLAKE2B |
          Alpha_context.Script.I_SHA256 | Alpha_context.Script.I_SHA512 |
          Alpha_context.Script.I_DIP | Alpha_context.Script.I_IF_NONE |
          Alpha_context.Script.I_LEFT | Alpha_context.Script.I_RIGHT |
          Alpha_context.Script.I_IF_LEFT | Alpha_context.Script.I_IF |
          Alpha_context.Script.I_LOOP | Alpha_context.Script.I_IF_CONS |
          Alpha_context.Script.I_IMPLICIT_ACCOUNT | Alpha_context.Script.I_NEG |
          Alpha_context.Script.I_ABS | Alpha_context.Script.I_INT |
          Alpha_context.Script.I_NOT | Alpha_context.Script.I_HASH_KEY |
          Alpha_context.Script.I_EQ | Alpha_context.Script.I_NEQ |
          Alpha_context.Script.I_LT | Alpha_context.Script.I_GT |
          Alpha_context.Script.I_LE | Alpha_context.Script.I_GE) as name) _ _,
          stack), _) =>
        Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            let '(stack, _ctxt) := function_parameter in
            Error_monad.fail extensible_type_value)
      |
        ((Micheline.Prim loc
          ((Alpha_context.Script.I_SWAP | Alpha_context.Script.I_PAIR |
          Alpha_context.Script.I_CONS | Alpha_context.Script.I_GET |
          Alpha_context.Script.I_MEM | Alpha_context.Script.I_EXEC |
          Alpha_context.Script.I_CHECK_SIGNATURE | Alpha_context.Script.I_ADD |
          Alpha_context.Script.I_SUB | Alpha_context.Script.I_MUL |
          Alpha_context.Script.I_EDIV | Alpha_context.Script.I_AND |
          Alpha_context.Script.I_OR | Alpha_context.Script.I_XOR |
          Alpha_context.Script.I_LSL | Alpha_context.Script.I_LSR) as name) _ _,
          stack), _) =>
        Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            let '(stack, _ctxt) := function_parameter in
            Error_monad.fail extensible_type_value)
      | ((expr, _), _) =>
        Pervasives.op_atat Error_monad.fail
          (unexpected expr [ Script_tc_errors.Seq_kind ]
            Script_tc_errors.Instr_namespace
            [
              Alpha_context.Script.I_DROP;
              Alpha_context.Script.I_DUP;
              Alpha_context.Script.I_DIG;
              Alpha_context.Script.I_DUG;
              Alpha_context.Script.I_SWAP;
              Alpha_context.Script.I_SOME;
              Alpha_context.Script.I_UNIT;
              Alpha_context.Script.I_PAIR;
              Alpha_context.Script.I_CAR;
              Alpha_context.Script.I_CDR;
              Alpha_context.Script.I_CONS;
              Alpha_context.Script.I_MEM;
              Alpha_context.Script.I_UPDATE;
              Alpha_context.Script.I_MAP;
              Alpha_context.Script.I_ITER;
              Alpha_context.Script.I_GET;
              Alpha_context.Script.I_EXEC;
              Alpha_context.Script.I_FAILWITH;
              Alpha_context.Script.I_SIZE;
              Alpha_context.Script.I_CONCAT;
              Alpha_context.Script.I_ADD;
              Alpha_context.Script.I_SUB;
              Alpha_context.Script.I_MUL;
              Alpha_context.Script.I_EDIV;
              Alpha_context.Script.I_OR;
              Alpha_context.Script.I_AND;
              Alpha_context.Script.I_XOR;
              Alpha_context.Script.I_NOT;
              Alpha_context.Script.I_ABS;
              Alpha_context.Script.I_INT;
              Alpha_context.Script.I_NEG;
              Alpha_context.Script.I_LSL;
              Alpha_context.Script.I_LSR;
              Alpha_context.Script.I_COMPARE;
              Alpha_context.Script.I_EQ;
              Alpha_context.Script.I_NEQ;
              Alpha_context.Script.I_LT;
              Alpha_context.Script.I_GT;
              Alpha_context.Script.I_LE;
              Alpha_context.Script.I_GE;
              Alpha_context.Script.I_TRANSFER_TOKENS;
              Alpha_context.Script.I_CREATE_ACCOUNT;
              Alpha_context.Script.I_CREATE_CONTRACT;
              Alpha_context.Script.I_NOW;
              Alpha_context.Script.I_AMOUNT;
              Alpha_context.Script.I_BALANCE;
              Alpha_context.Script.I_IMPLICIT_ACCOUNT;
              Alpha_context.Script.I_CHECK_SIGNATURE;
              Alpha_context.Script.I_BLAKE2B;
              Alpha_context.Script.I_SHA256;
              Alpha_context.Script.I_SHA512;
              Alpha_context.Script.I_HASH_KEY;
              Alpha_context.Script.I_STEPS_TO_QUOTA;
              Alpha_context.Script.I_PUSH;
              Alpha_context.Script.I_NONE;
              Alpha_context.Script.I_LEFT;
              Alpha_context.Script.I_RIGHT;
              Alpha_context.Script.I_NIL;
              Alpha_context.Script.I_EMPTY_SET;
              Alpha_context.Script.I_DIP;
              Alpha_context.Script.I_LOOP;
              Alpha_context.Script.I_IF_NONE;
              Alpha_context.Script.I_IF_LEFT;
              Alpha_context.Script.I_IF_CONS;
              Alpha_context.Script.I_EMPTY_MAP;
              Alpha_context.Script.I_IF;
              Alpha_context.Script.I_SOURCE;
              Alpha_context.Script.I_SENDER;
              Alpha_context.Script.I_SELF;
              Alpha_context.Script.I_LAMBDA
            ])
      end)

with parse_contract {arg : Set}
  (legacy : bool) (ctxt : Alpha_context.context)
  (loc : Alpha_context.Script.location) (arg : Script_typed_ir.ty arg)
  (contract : Alpha_context.Contract.t) (entrypoint : string) {struct legacy}
  : Lwt.t
    (Error_monad.tzresult
      (Alpha_context.context * Script_typed_ir.typed_contract arg)) :=
  Error_monad.op_gtgteqquestion
    (Pervasives.op_atat Lwt.__return
      (Alpha_context.Gas.consume ctxt Typecheck_costs.contract_exists))
    (fun ctxt =>
      Error_monad.op_gtgteqquestion
        (Alpha_context.Contract.__exists ctxt contract)
        (fun function_parameter =>
          match function_parameter with
          | false => Error_monad.fail extensible_type_value
          | true =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Alpha_context.Gas.consume ctxt Typecheck_costs.get_script))
              (fun ctxt =>
                Error_monad.op_gtgteqquestion
                  (Pervasives.op_atat (Error_monad.trace extensible_type_value)
                    (Alpha_context.Contract.get_script_code ctxt contract))
                  (fun function_parameter =>
                    let '(ctxt, code) := function_parameter in
                    match code with
                    | None =>
                      Lwt.__return
                        (Error_monad.op_gtgtquestion
                          (ty_eq ctxt arg (Script_typed_ir.Unit_t None))
                          (fun function_parameter =>
                            let '(Eq, ctxt) := function_parameter in
                            match entrypoint with
                            | "default" =>
                              let contract := (arg, (contract, entrypoint)) in
                              Error_monad.ok (ctxt, contract)
                            | entrypoint =>
                              Error_monad.__error_value extensible_type_value
                            end))
                    | Some code =>
                      Error_monad.op_gtgteqquestion
                        (Alpha_context.Script.force_decode ctxt code)
                        (fun function_parameter =>
                          let '(code, ctxt) := function_parameter in
                          Lwt.__return
                            (Error_monad.op_gtgtquestion
                              (parse_toplevel true code)
                              (fun function_parameter =>
                                let '(arg_type, _, _, root_name) :=
                                  function_parameter in
                                Error_monad.op_gtgtquestion
                                  (parse_parameter_ty ctxt true arg_type)
                                  (fun function_parameter =>
                                    let '(Ex_ty targ, ctxt) :=
                                      function_parameter in
                                    let __return
                                      (ctxt : Alpha_context.context)
                                      (targ : Script_typed_ir.ty arg)
                                      (entrypoint : string)
                                      : Error_monad.tzresult
                                        (Alpha_context.context *
                                          Script_typed_ir.typed_contract arg) :=
                                      Error_monad.op_gtgtquestion
                                        (merge_types legacy ctxt loc targ arg)
                                        (fun function_parameter =>
                                          let '(arg, ctxt) := function_parameter
                                            in
                                          let contract :=
                                            (arg, (contract, entrypoint)) in
                                          Error_monad.ok (ctxt, contract)) in
                                    Error_monad.op_gtgtquestion
                                      (find_entrypoint_for_type targ arg
                                        root_name entrypoint ctxt)
                                      (fun function_parameter =>
                                        let '(ctxt, entrypoint, targ) :=
                                          function_parameter in
                                        Error_monad.op_gtgtquestion
                                          (merge_types legacy ctxt loc targ arg)
                                          (fun function_parameter =>
                                            let '(targ, ctxt) :=
                                              function_parameter in
                                            __return ctxt targ entrypoint))))))
                    end))
          end))

with parse_contract_for_script {arg : Set}
  (legacy : bool) (ctxt : Alpha_context.context)
  (loc : Alpha_context.Script.location) (arg : Script_typed_ir.ty arg)
  (contract : Alpha_context.Contract.t) (entrypoint : string) {struct legacy}
  : Lwt.t
    (Error_monad.tzresult
      (Alpha_context.context * option (Script_typed_ir.typed_contract arg))) :=
  Error_monad.op_gtgteqquestion
    (Pervasives.op_atat Lwt.__return
      (Alpha_context.Gas.consume ctxt Typecheck_costs.contract_exists))
    (fun ctxt =>
      Error_monad.op_gtgteqquestion
        (Alpha_context.Contract.__exists ctxt contract)
        (fun function_parameter =>
          match function_parameter with
          | false => Error_monad.__return (ctxt, None)
          | true =>
            Error_monad.op_gtgteqquestion
              (Pervasives.op_atat Lwt.__return
                (Alpha_context.Gas.consume ctxt Typecheck_costs.get_script))
              (fun ctxt =>
                Error_monad.op_gtgteqquestion
                  (Pervasives.op_atat (Error_monad.trace extensible_type_value)
                    (Alpha_context.Contract.get_script_code ctxt contract))
                  (fun function_parameter =>
                    let '(ctxt, code) := function_parameter in
                    match code with
                    | None =>
                      match entrypoint with
                      | "default" =>
                        Lwt.__return
                          match ty_eq ctxt arg (Script_typed_ir.Unit_t None)
                            with
                          | Pervasives.Ok (Eq, ctxt) =>
                            let contract := (arg, (contract, entrypoint)) in
                            Error_monad.ok (ctxt, (Some contract))
                          | Pervasives.Error _ =>
                            Error_monad.op_gtgtquestion
                              (Alpha_context.Gas.consume ctxt
                                Typecheck_costs.cycle)
                              (fun ctxt => Error_monad.ok (ctxt, None))
                          end
                      | _ => Error_monad.__return (ctxt, None)
                      end
                    | Some code =>
                      Error_monad.op_gtgteqquestion
                        (Alpha_context.Script.force_decode ctxt code)
                        (fun function_parameter =>
                          let '(code, ctxt) := function_parameter in
                          Lwt.__return
                            match parse_toplevel true code with
                            | Pervasives.Error _ =>
                              Error_monad.__error_value extensible_type_value
                            | Pervasives.Ok (arg_type, _, _, root_name) =>
                              match parse_parameter_ty ctxt true arg_type with
                              | Pervasives.Error _ =>
                                Error_monad.__error_value extensible_type_value
                              | Pervasives.Ok (Ex_ty targ, ctxt) =>
                                match
                                  Error_monad.op_gtgtquestion
                                    (find_entrypoint_for_type targ arg root_name
                                      entrypoint ctxt)
                                    (fun function_parameter =>
                                      let '(ctxt, entrypoint, targ) :=
                                        function_parameter in
                                      Error_monad.op_gtgtquestion
                                        (merge_types legacy ctxt loc targ arg)
                                        (fun function_parameter =>
                                          let '(targ, ctxt) :=
                                            function_parameter in
                                          Error_monad.op_gtgtquestion
                                            (merge_types legacy ctxt loc targ
                                              arg)
                                            (fun function_parameter =>
                                              let '(arg, ctxt) :=
                                                function_parameter in
                                              let contract :=
                                                (arg, (contract, entrypoint)) in
                                              Error_monad.ok
                                                (ctxt, (Some contract))))) with
                                | Pervasives.Ok res => Error_monad.ok res
                                | Pervasives.Error _ =>
                                  Error_monad.op_gtgtquestion
                                    (ty_eq ctxt targ targ)
                                    (fun function_parameter =>
                                      let '(Eq, ctxt) := function_parameter in
                                      Error_monad.op_gtgtquestion
                                        (merge_types legacy ctxt loc targ targ)
                                        (fun function_parameter =>
                                          let '(_, ctxt) := function_parameter
                                            in
                                          Error_monad.ok (ctxt, None)))
                                end
                              end
                            end)
                    end))
          end))

with parse_toplevel (legacy : bool) (toplevel : Alpha_context.Script.expr)
  {struct legacy}
  : Error_monad.tzresult
    (Alpha_context.Script.node * Alpha_context.Script.node *
      Alpha_context.Script.node * option string) :=
  Pervasives.op_atat (Error_monad.record_trace extensible_type_value)
    match Micheline.root toplevel with
    | Micheline.Int loc _ => Error_monad.__error_value extensible_type_value
    | Micheline.String loc _ => Error_monad.__error_value extensible_type_value
    | Micheline.Bytes loc _ => Error_monad.__error_value extensible_type_value
    | Micheline.Prim loc _ _ _ =>
      Error_monad.__error_value extensible_type_value
    | Micheline.Seq _ fields =>
      let fix find_fields
        (p :
          option
            (Micheline.node Alpha_context.Script.location
              Alpha_context.Script.prim * Alpha_context.Script.location *
              Micheline.annot))
        (s :
          option
            (Micheline.node Alpha_context.Script.location
              Alpha_context.Script.prim * Alpha_context.Script.location *
              Micheline.annot))
        (c :
          option
            (Micheline.node Alpha_context.Script.location
              Alpha_context.Script.prim * Alpha_context.Script.location *
              Micheline.annot))
        (fields :
          list
            (Micheline.node Alpha_context.Script.location
              Alpha_context.Script.prim)) {struct p}
        : Error_monad.tzresult
          (option
            (Micheline.node Alpha_context.Script.location
              Alpha_context.Script.prim * Alpha_context.Script.location *
              Micheline.annot) *
            option
              (Micheline.node Alpha_context.Script.location
                Alpha_context.Script.prim * Alpha_context.Script.location *
                Micheline.annot) *
            option
              (Micheline.node Alpha_context.Script.location
                Alpha_context.Script.prim * Alpha_context.Script.location *
                Micheline.annot)) :=
        match fields with
        | [] => Error_monad.ok (p, s, c)
        | cons (Micheline.Int loc _) _ =>
          Error_monad.__error_value extensible_type_value
        | cons (Micheline.String loc _) _ =>
          Error_monad.__error_value extensible_type_value
        | cons (Micheline.Bytes loc _) _ =>
          Error_monad.__error_value extensible_type_value
        | cons (Micheline.Seq loc _) _ =>
          Error_monad.__error_value extensible_type_value
        |
          cons
            (Micheline.Prim loc Alpha_context.Script.K_parameter (cons arg [])
              annot) rest =>
          match p with
          | None => find_fields (Some (arg, loc, annot)) s c rest
          | Some _ => Error_monad.__error_value extensible_type_value
          end
        |
          cons
            (Micheline.Prim loc Alpha_context.Script.K_storage (cons arg [])
              annot) rest =>
          match s with
          | None => find_fields p (Some (arg, loc, annot)) c rest
          | Some _ => Error_monad.__error_value extensible_type_value
          end
        |
          cons
            (Micheline.Prim loc Alpha_context.Script.K_code (cons arg []) annot)
            rest =>
          match c with
          | None => find_fields p s (Some (arg, loc, annot)) rest
          | Some _ => Error_monad.__error_value extensible_type_value
          end
        |
          cons
            (Micheline.Prim loc
              ((Alpha_context.Script.K_parameter |
              Alpha_context.Script.K_storage | Alpha_context.Script.K_code) as
                name) args _) _ =>
          Error_monad.__error_value extensible_type_value
        | cons (Micheline.Prim loc name _ _) _ =>
          let allowed :=
            [
              Alpha_context.Script.K_parameter;
              Alpha_context.Script.K_storage;
              Alpha_context.Script.K_code
            ] in
          Error_monad.__error_value extensible_type_value
        end in
      Error_monad.op_gtgtquestion (find_fields None None None fields)
        (fun function_parameter =>
          match function_parameter with
          | (None, _, _) => Error_monad.__error_value extensible_type_value
          | (Some _, None, _) => Error_monad.__error_value extensible_type_value
          | (Some _, Some _, None) =>
            Error_monad.__error_value extensible_type_value
          |
            (Some (p, ploc, pannot), Some (s, sloc, sannot),
              Some (c, cloc, carrot)) =>
            let maybe_root_name :=
              Error_monad.op_gtgtquestion
                (Script_ir_annot.extract_field_annot p)
                (fun function_parameter =>
                  let '(p, root_name) := function_parameter in
                  match root_name with
                  | Some (Field_annot root_name) =>
                    Error_monad.ok (p, pannot, (Some root_name))
                  | None =>
                    match
                      (pannot,
                        match pannot with
                        | cons single [] =>
                          Pervasives.op_andand
                            ((|Compare.Int|).(Compare.S.op_gt)
                              (String.length single) 0)
                            ((|Compare.Char|).(Compare.S.op_eq)
                              (String.get single 0) "%" % char)
                        | _ => false
                        end) with
                    | (cons single [], true) =>
                      Error_monad.ok
                        (p, [],
                          (Some
                            (String.sub single 1
                              (Pervasives.op_minus (String.length single) 1))))
                    | (_, _) => Error_monad.ok (p, pannot, None)
                    end
                  end) in
            if legacy then
              let '(p, root_name) :=
                match maybe_root_name with
                | Pervasives.Ok (p, _, root_name) => (p, root_name)
                | Pervasives.Error _ => (p, None)
                end in
              Error_monad.ok (p, s, c, root_name)
            else
              Error_monad.op_gtgtquestion maybe_root_name
                (fun function_parameter =>
                  let '(p, pannot, root_name) := function_parameter in
                  Error_monad.op_gtgtquestion
                    (Script_ir_annot.error_unexpected_annot ploc pannot)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      Error_monad.op_gtgtquestion
                        (Script_ir_annot.error_unexpected_annot cloc carrot)
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          Error_monad.op_gtgtquestion
                            (Script_ir_annot.error_unexpected_annot sloc sannot)
                            (fun function_parameter =>
                              let '_ := function_parameter in
                              Error_monad.ok (p, s, c, root_name)))))
          end)
    end.

Definition parse_script
  (type_logger : option type_logger) (ctxt : Alpha_context.context)
  (legacy : bool) (function_parameter : Alpha_context.Script.t)
  : Lwt.t (Error_monad.tzresult (ex_script * Alpha_context.context)) :=
  let '{|
    Alpha_context.Script.t.code := code;
      Alpha_context.Script.t.storage := storage
      |} := function_parameter in
  Error_monad.op_gtgteqquestion (Alpha_context.Script.force_decode ctxt code)
    (fun function_parameter =>
      let '(code, ctxt) := function_parameter in
      Error_monad.op_gtgteqquestion
        (Alpha_context.Script.force_decode ctxt storage)
        (fun function_parameter =>
          let '(storage, ctxt) := function_parameter in
          Error_monad.op_gtgteqquestion
            (Pervasives.op_atat Lwt.__return (parse_toplevel legacy code))
            (fun function_parameter =>
              let '(arg_type, storage_type, code_field, root_name) :=
                function_parameter in
              Error_monad.op_gtgteqquestion
                (Error_monad.trace extensible_type_value
                  (Lwt.__return (parse_parameter_ty ctxt legacy arg_type)))
                (fun function_parameter =>
                  let '(Ex_ty arg_type, ctxt) := function_parameter in
                  Error_monad.op_gtgteqquestion
                    (if legacy then
                      Error_monad.__return tt
                    else
                      Lwt.__return (well_formed_entrypoints arg_type root_name))
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      Error_monad.op_gtgteqquestion
                        (Error_monad.trace extensible_type_value
                          (Lwt.__return
                            (parse_storage_ty ctxt legacy storage_type)))
                        (fun function_parameter =>
                          let '(Ex_ty storage_type, ctxt) := function_parameter
                            in
                          let arg_annot :=
                            Script_ir_annot.default_annot
                              Script_ir_annot.default_param_annot
                              (Script_ir_annot.type_to_var_annot
                                (name_of_ty arg_type)) in
                          let storage_annot :=
                            Script_ir_annot.default_annot
                              Script_ir_annot.default_storage_annot
                              (Script_ir_annot.type_to_var_annot
                                (name_of_ty storage_type)) in
                          let arg_type_full :=
                            Script_typed_ir.Pair_t (arg_type, None, arg_annot)
                              (storage_type, None, storage_annot) None
                              (Pervasives.op_pipepipe (has_big_map arg_type)
                                (has_big_map storage_type)) in
                          let ret_type_full :=
                            Script_typed_ir.Pair_t
                              ((Script_typed_ir.List_t
                                (Script_typed_ir.Operation_t None) None false),
                                None, None) (storage_type, None, None) None
                              (has_big_map storage_type) in
                          Error_monad.op_gtgteqquestion
                            (Error_monad.trace_eval
                              (fun function_parameter =>
                                let '_ := function_parameter in
                                Error_monad.op_gtgtpipequestion
                                  (Pervasives.op_atat Lwt.__return
                                    (serialize_ty_for_error ctxt storage_type))
                                  (fun function_parameter =>
                                    let '(storage_type, _ctxt) :=
                                      function_parameter in
                                    extensible_type_value))
                              (parse_data type_logger ctxt legacy storage_type
                                (Micheline.root storage)))
                            (fun function_parameter =>
                              let '(storage, ctxt) := function_parameter in
                              Error_monad.op_gtgteqquestion
                                (Error_monad.trace extensible_type_value
                                  (parse_returning type_logger
                                    (Toplevel
                                      {|
                                        tc_context.Toplevel.storage_type :=
                                          storage_type;
                                        tc_context.Toplevel.param_type :=
                                          arg_type;
                                        tc_context.Toplevel.root_name :=
                                          root_name;
                                        tc_context.Toplevel.legacy_create_contract_literal :=
                                          false |}) ctxt legacy
                                    (arg_type_full, None) ret_type_full
                                    code_field))
                                (fun function_parameter =>
                                  let '(code, ctxt) := function_parameter in
                                  Error_monad.__return
                                    ((Ex_script
                                      {| Script_typed_ir.script.code := code;
                                        Script_typed_ir.script.arg_type :=
                                          arg_type;
                                        Script_typed_ir.script.storage :=
                                          storage;
                                        Script_typed_ir.script.storage_type :=
                                          storage_type;
                                        Script_typed_ir.script.root_name :=
                                          root_name |}), ctxt))))))))).

Definition typecheck_code
  (ctxt : Alpha_context.context) (code : Alpha_context.Script.expr)
  : Lwt.t
    (Error_monad.tzresult (Script_tc_errors.type_map * Alpha_context.context)) :=
  let legacy := false in
  Error_monad.op_gtgteqquestion
    (Pervasives.op_atat Lwt.__return (parse_toplevel legacy code))
    (fun function_parameter =>
      let '(arg_type, storage_type, code_field, root_name) := function_parameter
        in
      let type_map := Pervasives.__ref_value [] in
      Error_monad.op_gtgteqquestion
        (Error_monad.trace extensible_type_value
          (Lwt.__return (parse_parameter_ty ctxt legacy arg_type)))
        (fun function_parameter =>
          let '(Ex_ty arg_type, ctxt) := function_parameter in
          Error_monad.op_gtgteqquestion
            (if legacy then
              Error_monad.__return tt
            else
              Lwt.__return (well_formed_entrypoints arg_type root_name))
            (fun function_parameter =>
              let '_ := function_parameter in
              Error_monad.op_gtgteqquestion
                (Error_monad.trace extensible_type_value
                  (Lwt.__return (parse_storage_ty ctxt legacy storage_type)))
                (fun function_parameter =>
                  let '(Ex_ty storage_type, ctxt) := function_parameter in
                  let arg_annot :=
                    Script_ir_annot.default_annot
                      Script_ir_annot.default_param_annot
                      (Script_ir_annot.type_to_var_annot (name_of_ty arg_type))
                    in
                  let storage_annot :=
                    Script_ir_annot.default_annot
                      Script_ir_annot.default_storage_annot
                      (Script_ir_annot.type_to_var_annot
                        (name_of_ty storage_type)) in
                  let arg_type_full :=
                    Script_typed_ir.Pair_t (arg_type, None, arg_annot)
                      (storage_type, None, storage_annot) None
                      (Pervasives.op_pipepipe (has_big_map arg_type)
                        (has_big_map storage_type)) in
                  let ret_type_full :=
                    Script_typed_ir.Pair_t
                      ((Script_typed_ir.List_t
                        (Script_typed_ir.Operation_t None) None false), None,
                        None) (storage_type, None, None) None
                      (has_big_map storage_type) in
                  let __result_value :=
                    parse_returning
                      (Some
                        (fun loc =>
                          fun bef =>
                            fun aft =>
                              Pervasives.op_coloneq type_map
                                (cons (loc, (bef, aft))
                                  (Pervasives.op_exclamation type_map))))
                      (Toplevel
                        {| tc_context.Toplevel.storage_type := storage_type;
                          tc_context.Toplevel.param_type := arg_type;
                          tc_context.Toplevel.root_name := root_name;
                          tc_context.Toplevel.legacy_create_contract_literal :=
                            false |}) ctxt legacy (arg_type_full, None)
                      ret_type_full code_field in
                  Error_monad.op_gtgteqquestion
                    (Error_monad.trace extensible_type_value __result_value)
                    (fun function_parameter =>
                      let '(Script_typed_ir.Lam _ _, ctxt) := function_parameter
                        in
                      Error_monad.__return
                        ((Pervasives.op_exclamation type_map), ctxt)))))).

Definition typecheck_data
  (type_logger : option type_logger) (ctxt : Alpha_context.context)
  (function_parameter : Alpha_context.Script.expr * Alpha_context.Script.expr)
  : Lwt.t (Error_monad.tzresult Alpha_context.context) :=
  let '(data, exp_ty) := function_parameter in
  let legacy := false in
  Error_monad.op_gtgteqquestion
    (Error_monad.trace extensible_type_value
      (Pervasives.op_atat Lwt.__return
        (parse_packable_ty ctxt legacy (Micheline.root exp_ty))))
    (fun function_parameter =>
      let '(Ex_ty exp_ty, ctxt) := function_parameter in
      Error_monad.op_gtgteqquestion
        (Error_monad.trace_eval
          (fun function_parameter =>
            let '_ := function_parameter in
            Error_monad.op_gtgtpipequestion
              (Pervasives.op_atat Lwt.__return
                (serialize_ty_for_error ctxt exp_ty))
              (fun function_parameter =>
                let '(exp_ty, _ctxt) := function_parameter in
                extensible_type_value))
          (parse_data type_logger ctxt legacy exp_ty (Micheline.root data)))
        (fun function_parameter =>
          let '(_, ctxt) := function_parameter in
          Error_monad.__return ctxt)).

Definition Entrypoints_map :=
  Map.Make
    (existT _ _
      {|
        Compare.COMPARABLE.compare := String.compare
      |}).

Definition list_entrypoints {A : Set}
  (full : Script_typed_ir.ty A) (ctxt : Alpha_context.context)
  (root_name : option (|Entrypoints_map|).(S.MAP.key))
  : Error_monad.tzresult
    (list (list Alpha_context.Script.prim) *
      (|Entrypoints_map|).(S.MAP.t)
        (list Alpha_context.Script.prim * Alpha_context.Script.node)) :=
  let merge {B C : Set}
    (path : list B)
    (annot : option (* `Field_annot *) (|Entrypoints_map|).(S.MAP.key))
    (ty : Script_typed_ir.ty C) (reachable : bool)
    (function_parameter :
      list (list B) *
        (|Entrypoints_map|).(S.MAP.t) (list B * Alpha_context.Script.node))
    : Error_monad.tzresult
      (list (list B) *
        (|Entrypoints_map|).(S.MAP.t) (list B * Alpha_context.Script.node)) :=
    let '(unreachables, all) as acc := function_parameter in
    match annot with
    | None | Some (Field_annot "") =>
      Pervasives.op_atat Error_monad.ok
        (if reachable then
          acc
        else
          match ty with
          | Script_typed_ir.Union_t _ _ _ _ => acc
          | _ => ((cons (List.rev path) unreachables), all)
          end)
    | Some (Field_annot name) =>
      if (|Compare.Int|).(Compare.S.op_gt) (String.length name) 31 then
        Error_monad.ok ((cons (List.rev path) unreachables), all)
      else
        if (|Entrypoints_map|).(S.MAP.mem) name all then
          Error_monad.ok ((cons (List.rev path) unreachables), all)
        else
          Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt ty)
            (fun function_parameter =>
              let '(unparsed_ty, _) := function_parameter in
              Error_monad.ok
                (unreachables,
                  ((|Entrypoints_map|).(S.MAP.add) name
                    ((List.rev path), unparsed_ty) all)))
    end in
  let fix fold_tree {t : Set}
    (__t_value : Script_typed_ir.ty t) (path : list Alpha_context.Script.prim)
    (reachable : bool)
    (acc :
      list (list Alpha_context.Script.prim) *
        (|Entrypoints_map|).(S.MAP.t)
          (list Alpha_context.Script.prim * Alpha_context.Script.node))
    {struct __t_value}
    : Error_monad.tzresult
      (list (list Alpha_context.Script.prim) *
        (|Entrypoints_map|).(S.MAP.t)
          (list Alpha_context.Script.prim * Alpha_context.Script.node)) :=
    match __t_value with
    | Script_typed_ir.Union_t (tl, al) (tr, ar) _ _ =>
      Error_monad.op_gtgtquestion
        (merge (cons Alpha_context.Script.D_Left path) al tl reachable acc)
        (fun acc =>
          Error_monad.op_gtgtquestion
            (merge (cons Alpha_context.Script.D_Right path) ar tr reachable acc)
            (fun acc =>
              Error_monad.op_gtgtquestion
                (fold_tree tl (cons Alpha_context.Script.D_Left path)
                  match al with
                  | Some _ => true
                  | None => reachable
                  end acc)
                (fun acc =>
                  fold_tree tr (cons Alpha_context.Script.D_Right path)
                    match ar with
                    | Some _ => true
                    | None => reachable
                    end acc)))
    | _ => Error_monad.ok acc
    end in
  Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt full)
    (fun function_parameter =>
      let '(unparsed_full, _) := function_parameter in
      let '(init, reachable) :=
        match root_name with
        | None | Some "" => ((|Entrypoints_map|).(S.MAP.empty), false)
        | Some name =>
          (((|Entrypoints_map|).(S.MAP.singleton) name ([], unparsed_full)),
            true)
        end in
      fold_tree full [] reachable ([], init)).

Fixpoint unparse_data {a : Set}
  (ctxt : Alpha_context.context) (mode : unparsing_mode)
  (ty : Script_typed_ir.ty a) (a : a) {struct ctxt}
  : Lwt.t
    (Error_monad.tzresult (Alpha_context.Script.node * Alpha_context.context)) :=
  Error_monad.op_gtgteqquestion
    (Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.cycle))
    (fun ctxt =>
      match (ty, a) with
      | (Script_typed_ir.Unit_t _, _) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt Unparse_costs.__unit_value))
          (fun ctxt =>
            Error_monad.__return
              ((Micheline.Prim (-1) Alpha_context.Script.D_Unit [] []), ctxt))
      | (Script_typed_ir.Int_t _, v) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt (Unparse_costs.int v)))
          (fun ctxt =>
            Error_monad.__return
              ((Micheline.Int (-1) (Alpha_context.Script_int.to_zint v)), ctxt))
      | (Script_typed_ir.Nat_t _, v) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt (Unparse_costs.int v)))
          (fun ctxt =>
            Error_monad.__return
              ((Micheline.Int (-1) (Alpha_context.Script_int.to_zint v)), ctxt))
      | (Script_typed_ir.String_t _, s) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt (Unparse_costs.__string_value s)))
          (fun ctxt => Error_monad.__return ((Micheline.String (-1) s), ctxt))
      | (Script_typed_ir.Bytes_t _, s) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt (Unparse_costs.__bytes_value s)))
          (fun ctxt => Error_monad.__return ((Micheline.Bytes (-1) s), ctxt))
      | (Script_typed_ir.Bool_t _, true) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt Unparse_costs.__bool_value))
          (fun ctxt =>
            Error_monad.__return
              ((Micheline.Prim (-1) Alpha_context.Script.D_True [] []), ctxt))
      | (Script_typed_ir.Bool_t _, false) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt Unparse_costs.__bool_value))
          (fun ctxt =>
            Error_monad.__return
              ((Micheline.Prim (-1) Alpha_context.Script.D_False [] []), ctxt))
      | (Script_typed_ir.Timestamp_t _, __t_value) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt (Unparse_costs.timestamp __t_value)))
          (fun ctxt =>
            match mode with
            | Optimized =>
              Error_monad.__return
                ((Micheline.Int (-1)
                  (Alpha_context.Script_timestamp.to_zint __t_value)), ctxt)
            | Readable =>
              match Alpha_context.Script_timestamp.to_notation __t_value with
              | None =>
                Error_monad.__return
                  ((Micheline.Int (-1)
                    (Alpha_context.Script_timestamp.to_zint __t_value)), ctxt)
              | Some s => Error_monad.__return ((Micheline.String (-1) s), ctxt)
              end
            end)
      | (Script_typed_ir.Address_t _, (c, entrypoint)) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.contract))
          (fun ctxt =>
            match mode with
            | Optimized =>
              let entrypoint :=
                match entrypoint with
                | "default" => ""
                | name => name
                end in
              let __bytes_value :=
                Data_encoding.Binary.to_bytes_exn
                  (Data_encoding.tup2 Alpha_context.Contract.encoding
                    Data_encoding.__Variable.__string_value) (c, entrypoint) in
              Error_monad.__return ((Micheline.Bytes (-1) __bytes_value), ctxt)
            | Readable =>
              let notation :=
                match entrypoint with
                | "default" => Alpha_context.Contract.to_b58check c
                | entrypoint =>
                  Pervasives.op_caret (Alpha_context.Contract.to_b58check c)
                    (Pervasives.op_caret "%" entrypoint)
                end in
              Error_monad.__return ((Micheline.String (-1) notation), ctxt)
            end)
      | (Script_typed_ir.Contract_t _ _, (_, (c, entrypoint))) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.contract))
          (fun ctxt =>
            match mode with
            | Optimized =>
              let entrypoint :=
                match entrypoint with
                | "default" => ""
                | name => name
                end in
              let __bytes_value :=
                Data_encoding.Binary.to_bytes_exn
                  (Data_encoding.tup2 Alpha_context.Contract.encoding
                    Data_encoding.__Variable.__string_value) (c, entrypoint) in
              Error_monad.__return ((Micheline.Bytes (-1) __bytes_value), ctxt)
            | Readable =>
              let notation :=
                match entrypoint with
                | "default" => Alpha_context.Contract.to_b58check c
                | entrypoint =>
                  Pervasives.op_caret (Alpha_context.Contract.to_b58check c)
                    (Pervasives.op_caret "%" entrypoint)
                end in
              Error_monad.__return ((Micheline.String (-1) notation), ctxt)
            end)
      | (Script_typed_ir.Signature_t _, s) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.signature))
          (fun ctxt =>
            match mode with
            | Optimized =>
              let __bytes_value :=
                Data_encoding.Binary.to_bytes_exn Signature.encoding s in
              Error_monad.__return ((Micheline.Bytes (-1) __bytes_value), ctxt)
            | Readable =>
              Error_monad.__return
                ((Micheline.String (-1) (Signature.to_b58check s)), ctxt)
            end)
      | (Script_typed_ir.Mutez_t _, v) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.tez))
          (fun ctxt =>
            Error_monad.__return
              ((Micheline.Int (-1) (Z.of_int64 (Alpha_context.Tez.to_mutez v))),
                ctxt))
      | (Script_typed_ir.Key_t _, k) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.key))
          (fun ctxt =>
            match mode with
            | Optimized =>
              let __bytes_value :=
                Data_encoding.Binary.to_bytes_exn
                  (|Signature.Public_key|).(S.SPublic_key.encoding) k in
              Error_monad.__return ((Micheline.Bytes (-1) __bytes_value), ctxt)
            | Readable =>
              Error_monad.__return
                ((Micheline.String (-1)
                  ((|Signature.Public_key|).(S.SPublic_key.to_b58check) k)),
                  ctxt)
            end)
      | (Script_typed_ir.Key_hash_t _, k) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.key_hash))
          (fun ctxt =>
            match mode with
            | Optimized =>
              let __bytes_value :=
                Data_encoding.Binary.to_bytes_exn
                  (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding) k
                in
              Error_monad.__return ((Micheline.Bytes (-1) __bytes_value), ctxt)
            | Readable =>
              Error_monad.__return
                ((Micheline.String (-1)
                  ((|Signature.Public_key_hash|).(S.SPublic_key_hash.to_b58check)
                    k)), ctxt)
            end)
      | (Script_typed_ir.Operation_t _, (op, _big_map_diff)) =>
        let __bytes_value :=
          Data_encoding.Binary.to_bytes_exn
            Alpha_context.Operation.internal_operation_encoding op in
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt
              (Unparse_costs.operation __bytes_value)))
          (fun ctxt =>
            Error_monad.__return ((Micheline.Bytes (-1) __bytes_value), ctxt))
      | (Script_typed_ir.Chain_id_t _, chain_id) =>
        let __bytes_value :=
          Data_encoding.Binary.to_bytes_exn (|Chain_id|).(S.HASH.encoding)
            chain_id in
        Error_monad.op_gtgteqquestion
          (Lwt.__return
            (Alpha_context.Gas.consume ctxt
              (Unparse_costs.chain_id __bytes_value)))
          (fun ctxt =>
            Error_monad.__return ((Micheline.Bytes (-1) __bytes_value), ctxt))
      | (Script_typed_ir.Pair_t (tl, _, _) (tr, _, _) _ _, (l, r)) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.pair))
          (fun ctxt =>
            Error_monad.op_gtgteqquestion (unparse_data ctxt mode tl l)
              (fun function_parameter =>
                let '(l, ctxt) := function_parameter in
                Error_monad.op_gtgteqquestion (unparse_data ctxt mode tr r)
                  (fun function_parameter =>
                    let '(r, ctxt) := function_parameter in
                    Error_monad.__return
                      ((Micheline.Prim (-1) Alpha_context.Script.D_Pair [ l; r ]
                        []), ctxt))))
      | (Script_typed_ir.Union_t (tl, _) _ _ _, Script_typed_ir.L l) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.union))
          (fun ctxt =>
            Error_monad.op_gtgteqquestion (unparse_data ctxt mode tl l)
              (fun function_parameter =>
                let '(l, ctxt) := function_parameter in
                Error_monad.__return
                  ((Micheline.Prim (-1) Alpha_context.Script.D_Left [ l ] []),
                    ctxt)))
      | (Script_typed_ir.Union_t _ (tr, _) _ _, Script_typed_ir.R r) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.union))
          (fun ctxt =>
            Error_monad.op_gtgteqquestion (unparse_data ctxt mode tr r)
              (fun function_parameter =>
                let '(r, ctxt) := function_parameter in
                Error_monad.__return
                  ((Micheline.Prim (-1) Alpha_context.Script.D_Right [ r ] []),
                    ctxt)))
      | (Script_typed_ir.Option_t __t_value _ _, Some v) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.some))
          (fun ctxt =>
            Error_monad.op_gtgteqquestion (unparse_data ctxt mode __t_value v)
              (fun function_parameter =>
                let '(v, ctxt) := function_parameter in
                Error_monad.__return
                  ((Micheline.Prim (-1) Alpha_context.Script.D_Some [ v ] []),
                    ctxt)))
      | (Script_typed_ir.Option_t _ _ _, None) =>
        Error_monad.op_gtgteqquestion
          (Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.none))
          (fun ctxt =>
            Error_monad.__return
              ((Micheline.Prim (-1) Alpha_context.Script.D_None [] []), ctxt))
      | (Script_typed_ir.List_t __t_value _ _, items) =>
        Error_monad.op_gtgteqquestion
          (Error_monad.fold_left_s
            (fun function_parameter =>
              let '(l, ctxt) := function_parameter in
              fun element =>
                Error_monad.op_gtgteqquestion
                  (Lwt.__return
                    (Alpha_context.Gas.consume ctxt Unparse_costs.list_element))
                  (fun ctxt =>
                    Error_monad.op_gtgteqquestion
                      (unparse_data ctxt mode __t_value element)
                      (fun function_parameter =>
                        let '(unparsed, ctxt) := function_parameter in
                        Error_monad.__return ((cons unparsed l), ctxt))))
            ([], ctxt) items)
          (fun function_parameter =>
            let '(items, ctxt) := function_parameter in
            Error_monad.__return ((Micheline.Seq (-1) (List.rev items)), ctxt))
      | (Script_typed_ir.Set_t __t_value _, set) =>
        let __t_value := ty_of_comparable_ty __t_value in
        Error_monad.op_gtgteqquestion
          (Error_monad.fold_left_s
            (fun function_parameter =>
              let '(l, ctxt) := function_parameter in
              fun item =>
                Error_monad.op_gtgteqquestion
                  (Lwt.__return
                    (Alpha_context.Gas.consume ctxt Unparse_costs.set_element))
                  (fun ctxt =>
                    Error_monad.op_gtgteqquestion
                      (unparse_data ctxt mode __t_value item)
                      (fun function_parameter =>
                        let '(item, ctxt) := function_parameter in
                        Error_monad.__return ((cons item l), ctxt)))) ([], ctxt)
            (set_fold (fun e => fun acc => cons e acc) set []))
          (fun function_parameter =>
            let '(items, ctxt) := function_parameter in
            Error_monad.__return ((Micheline.Seq (-1) items), ctxt))
      | (Script_typed_ir.Map_t kt vt _ _, map) =>
        let kt := ty_of_comparable_ty kt in
        Error_monad.op_gtgteqquestion
          (Error_monad.fold_left_s
            (fun function_parameter =>
              let '(l, ctxt) := function_parameter in
              fun function_parameter =>
                let '(k, v) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Lwt.__return
                    (Alpha_context.Gas.consume ctxt Unparse_costs.map_element))
                  (fun ctxt =>
                    Error_monad.op_gtgteqquestion (unparse_data ctxt mode kt k)
                      (fun function_parameter =>
                        let '(key, ctxt) := function_parameter in
                        Error_monad.op_gtgteqquestion
                          (unparse_data ctxt mode vt v)
                          (fun function_parameter =>
                            let '(value, ctxt) := function_parameter in
                            Error_monad.__return
                              ((cons
                                (Micheline.Prim (-1) Alpha_context.Script.D_Elt
                                  [ key; value ] []) l), ctxt))))) ([], ctxt)
            (map_fold (fun k => fun v => fun acc => cons (k, v) acc) map []))
          (fun function_parameter =>
            let '(items, ctxt) := function_parameter in
            Error_monad.__return ((Micheline.Seq (-1) items), ctxt))
      |
        (Script_typed_ir.Big_map_t kt vt _, {|
          Script_typed_ir.big_map.id := None;
            Script_typed_ir.big_map.diff := Diff
            |}) =>
        let kt := ty_of_comparable_ty kt in
        Error_monad.op_gtgteqquestion
          (Error_monad.fold_left_s
            (fun function_parameter =>
              let '(l, ctxt) := function_parameter in
              fun function_parameter =>
                let '(k, v) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Lwt.__return
                    (Alpha_context.Gas.consume ctxt Unparse_costs.map_element))
                  (fun ctxt =>
                    Error_monad.op_gtgteqquestion (unparse_data ctxt mode kt k)
                      (fun function_parameter =>
                        let '(key, ctxt) := function_parameter in
                        Error_monad.op_gtgteqquestion
                          (unparse_data ctxt mode vt v)
                          (fun function_parameter =>
                            let '(value, ctxt) := function_parameter in
                            Error_monad.__return
                              ((cons
                                (Micheline.Prim (-1) Alpha_context.Script.D_Elt
                                  [ key; value ] []) l), ctxt))))) ([], ctxt)
            ((|Diff|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.fold)
              (fun k =>
                fun v =>
                  fun acc =>
                    match v with
                    | None => acc
                    | Some v => cons (k, v) acc
                    end)
              (Pervasives.fst (|Diff|).(Script_typed_ir.Boxed_map.boxed)) []))
          (fun function_parameter =>
            let '(items, ctxt) := function_parameter in
            Error_monad.__return ((Micheline.Seq (-1) items), ctxt))
      |
        (Script_typed_ir.Big_map_t _kt _kv _, {|
          Script_typed_ir.big_map.id := Some id;
            Script_typed_ir.big_map.diff := Diff
            |}) =>
        if
          (|Compare.Int|).(Compare.S.op_eq)
            ((|Diff|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.cardinal)
              (Pervasives.fst (|Diff|).(Script_typed_ir.Boxed_map.boxed))) 0
          then
          Error_monad.__return ((Micheline.Int (-1) id), ctxt)
        else
          (* ❌ Assert instruction is not handled. *)
          assert false
      | (Script_typed_ir.Lambda_t _ _ _, Script_typed_ir.Lam _ original_code) =>
        unparse_code ctxt mode original_code
      end)

with unparse_code (ctxt : Alpha_context.context) (mode : unparsing_mode)
  {struct ctxt}
  : Alpha_context.Script.node ->
  Lwt.t
    (Error_monad.tzresult
      (Micheline.node Z Alpha_context.Script.prim * Alpha_context.context)) :=
  let legacy := true in
  fun function_parameter =>
    match function_parameter with
    |
      Micheline.Prim loc Alpha_context.Script.I_PUSH (cons ty (cons data []))
        annot =>
      Error_monad.op_gtgteqquestion
        (Lwt.__return (parse_packable_ty ctxt legacy ty))
        (fun function_parameter =>
          let '(Ex_ty __t_value, ctxt) := function_parameter in
          Error_monad.op_gtgteqquestion
            (parse_data None ctxt legacy __t_value data)
            (fun function_parameter =>
              let '(data, ctxt) := function_parameter in
              Error_monad.op_gtgteqquestion
                (unparse_data ctxt mode __t_value data)
                (fun function_parameter =>
                  let '(data, ctxt) := function_parameter in
                  Error_monad.op_gtgteqquestion
                    (Lwt.__return
                      (Alpha_context.Gas.consume ctxt
                        (Unparse_costs.prim_cost 2 annot)))
                    (fun ctxt =>
                      Error_monad.__return
                        ((Micheline.Prim loc Alpha_context.Script.I_PUSH
                          [ ty; data ] annot), ctxt)))))
    | Micheline.Seq loc items =>
      Error_monad.op_gtgteqquestion
        (Error_monad.fold_left_s
          (fun function_parameter =>
            let '(l, ctxt) := function_parameter in
            fun item =>
              Error_monad.op_gtgteqquestion (unparse_code ctxt mode item)
                (fun function_parameter =>
                  let '(item, ctxt) := function_parameter in
                  Error_monad.__return ((cons item l), ctxt))) ([], ctxt) items)
        (fun function_parameter =>
          let '(items, ctxt) := function_parameter in
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt
                (Unparse_costs.seq_cost (List.length items))))
            (fun ctxt =>
              Error_monad.__return ((Micheline.Seq loc (List.rev items)), ctxt)))
    | Micheline.Prim loc prim items annot =>
      Error_monad.op_gtgteqquestion
        (Error_monad.fold_left_s
          (fun function_parameter =>
            let '(l, ctxt) := function_parameter in
            fun item =>
              Error_monad.op_gtgteqquestion (unparse_code ctxt mode item)
                (fun function_parameter =>
                  let '(item, ctxt) := function_parameter in
                  Error_monad.__return ((cons item l), ctxt))) ([], ctxt) items)
        (fun function_parameter =>
          let '(items, ctxt) := function_parameter in
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              (Alpha_context.Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)))
            (fun ctxt =>
              Error_monad.__return
                ((Micheline.Prim loc prim (List.rev items) annot), ctxt)))
    | (Micheline.Int _ _ | Micheline.String _ _ | Micheline.Bytes _ _) as atom
      => Error_monad.__return (atom, ctxt)
    end.

Definition unparse_script {A B : Set}
  (ctxt : Alpha_context.context) (mode : unparsing_mode)
  (function_parameter : Script_typed_ir.script A B)
  : Lwt.t
    (Error_monad.tzresult (Alpha_context.Script.t * Alpha_context.context)) :=
  let '{|
    Script_typed_ir.script.code := code;
      Script_typed_ir.script.arg_type := arg_type;
      Script_typed_ir.script.storage := storage;
      Script_typed_ir.script.storage_type := storage_type;
      Script_typed_ir.script.root_name := root_name
      |} := function_parameter in
  let 'Script_typed_ir.Lam _ original_code := code in
  Error_monad.op_gtgteqquestion (unparse_code ctxt mode original_code)
    (fun function_parameter =>
      let '(code, ctxt) := function_parameter in
      Error_monad.op_gtgteqquestion
        (unparse_data ctxt mode storage_type storage)
        (fun function_parameter =>
          let '(storage, ctxt) := function_parameter in
          Error_monad.op_gtgteqquestion (unparse_ty ctxt arg_type)
            (fun function_parameter =>
              let '(arg_type, ctxt) := function_parameter in
              Error_monad.op_gtgteqquestion (unparse_ty ctxt storage_type)
                (fun function_parameter =>
                  let '(storage_type, ctxt) := function_parameter in
                  let arg_type :=
                    add_field_annot
                      (Option.map
                        (fun n =>
                          (* ❌ Variants not supported *)
                          (* ❌ `Field_annot *)
                          Field_annot n) root_name) None arg_type in
                  let code :=
                    Micheline.Seq (-1)
                      [
                        Micheline.Prim (-1) Alpha_context.Script.K_parameter
                          [ arg_type ] [];
                        Micheline.Prim (-1) Alpha_context.Script.K_storage
                          [ storage_type ] [];
                        Micheline.Prim (-1) Alpha_context.Script.K_code [ code ]
                          []
                      ] in
                  Error_monad.op_gtgteqquestion
                    (Lwt.__return
                      (Error_monad.op_gtgtquestion
                        (Alpha_context.Gas.consume ctxt
                          (Unparse_costs.seq_cost 3))
                        (fun ctxt =>
                          Error_monad.op_gtgtquestion
                            (Alpha_context.Gas.consume ctxt
                              (Unparse_costs.prim_cost 1 []))
                            (fun ctxt =>
                              Error_monad.op_gtgtquestion
                                (Alpha_context.Gas.consume ctxt
                                  (Unparse_costs.prim_cost 1 []))
                                (fun ctxt =>
                                  Alpha_context.Gas.consume ctxt
                                    (Unparse_costs.prim_cost 1 []))))))
                    (fun ctxt =>
                      Error_monad.__return
                        ({|
                          Alpha_context.Script.t.code :=
                            Alpha_context.Script.__lazy_expr_value
                              (Micheline.strip_locations code);
                          Alpha_context.Script.t.storage :=
                            Alpha_context.Script.__lazy_expr_value
                              (Micheline.strip_locations storage) |}, ctxt)))))).

Definition pack_data {A : Set}
  (ctxt : Alpha_context.context) (typ : Script_typed_ir.ty A) (data : A)
  : Lwt.t (Error_monad.tzresult (MBytes.t * Alpha_context.context)) :=
  Error_monad.op_gtgteqquestion (unparse_data ctxt Optimized typ data)
    (fun function_parameter =>
      let '(unparsed, ctxt) := function_parameter in
      let __bytes_value :=
        Data_encoding.Binary.to_bytes_exn Alpha_context.Script.expr_encoding
          (Micheline.strip_locations unparsed) in
      Error_monad.op_gtgteqquestion
        (Pervasives.op_atat Lwt.__return
          (Alpha_context.Gas.consume ctxt
            (Alpha_context.Script.serialized_cost __bytes_value)))
        (fun ctxt =>
          let __bytes_value :=
            MBytes.concat "" [ MBytes.of_string "\005"; __bytes_value ] in
          Error_monad.op_gtgteqquestion
            (Pervasives.op_atat Lwt.__return
              (Alpha_context.Gas.consume ctxt
                (Alpha_context.Script.serialized_cost __bytes_value)))
            (fun ctxt => Error_monad.__return (__bytes_value, ctxt)))).

Definition hash_data {A : Set}
  (ctxt : Alpha_context.context) (typ : Script_typed_ir.ty A) (data : A)
  : Lwt.t (Error_monad.tzresult (Script_expr_hash.t * Alpha_context.context)) :=
  Error_monad.op_gtgteqquestion (pack_data ctxt typ data)
    (fun function_parameter =>
      let '(__bytes_value, ctxt) := function_parameter in
      Error_monad.op_gtgteqquestion
        (Pervasives.op_atat Lwt.__return
          (Alpha_context.Gas.consume ctxt
            (Michelson_v1_gas.Cost_of.Legacy.__hash_value __bytes_value
              Script_expr_hash.size)))
        (fun ctxt =>
          Error_monad.__return
            ((Script_expr_hash.hash_bytes None [ __bytes_value ]), ctxt))).

Definition empty_big_map {A B : Set}
  (tk : Script_typed_ir.comparable_ty A) (tv : Script_typed_ir.ty B)
  : Script_typed_ir.big_map A B :=
  {| Script_typed_ir.big_map.id := None;
    Script_typed_ir.big_map.diff := empty_map tk;
    Script_typed_ir.big_map.key_type := ty_of_comparable_ty tk;
    Script_typed_ir.big_map.value_type := tv |}.

Definition big_map_mem {A B : Set}
  (ctxt : Alpha_context.context) (key : A)
  (function_parameter : Script_typed_ir.big_map A B)
  : Lwt.t (Error_monad.tzresult (bool * Alpha_context.context)) :=
  let '{|
    Script_typed_ir.big_map.id := id;
      Script_typed_ir.big_map.diff := diff;
      Script_typed_ir.big_map.key_type := key_type
      |} := function_parameter in
  match ((map_get key diff), id) with
  | (None, None) => Error_monad.__return (false, ctxt)
  | (None, Some id) =>
    Error_monad.op_gtgteqquestion (hash_data ctxt key_type key)
      (fun function_parameter =>
        let '(__hash_value, ctxt) := function_parameter in
        Error_monad.op_gtgteqquestion
          (Alpha_context.Big_map.mem ctxt id __hash_value)
          (fun function_parameter =>
            let '(ctxt, res) := function_parameter in
            Error_monad.__return (res, ctxt)))
  | (Some None, _) => Error_monad.__return (false, ctxt)
  | (Some (Some _), _) => Error_monad.__return (true, ctxt)
  end.

Definition big_map_get {A B : Set}
  (ctxt : Alpha_context.context) (key : A)
  (function_parameter : Script_typed_ir.big_map A B)
  : Lwt.t (Error_monad.tzresult (option B * Alpha_context.context)) :=
  let '{|
    Script_typed_ir.big_map.id := id;
      Script_typed_ir.big_map.diff := diff;
      Script_typed_ir.big_map.key_type := key_type;
      Script_typed_ir.big_map.value_type := value_type
      |} := function_parameter in
  match ((map_get key diff), id) with
  | (Some x, _) => Error_monad.__return (x, ctxt)
  | (None, None) => Error_monad.__return (None, ctxt)
  | (None, Some id) =>
    Error_monad.op_gtgteqquestion (hash_data ctxt key_type key)
      (fun function_parameter =>
        let '(__hash_value, ctxt) := function_parameter in
        Error_monad.op_gtgteqquestion
          (Alpha_context.Big_map.get_opt ctxt id __hash_value)
          (fun function_parameter =>
            match function_parameter with
            | (ctxt, None) => Error_monad.__return (None, ctxt)
            | (ctxt, Some value) =>
              Error_monad.op_gtgteqquestion
                (parse_data None ctxt true value_type (Micheline.root value))
                (fun function_parameter =>
                  let '(x, ctxt) := function_parameter in
                  Error_monad.__return ((Some x), ctxt))
            end))
  end.

Definition big_map_update {A B : Set}
  (key : A) (value : option B)
  (function_parameter : Script_typed_ir.big_map A B)
  : Script_typed_ir.big_map A B :=
  let '{| Script_typed_ir.big_map.diff := diff |} as map := function_parameter
    in
  Script_typed_ir.big_map.with_diff (map_set key value diff) map.

Definition Ids :=
  __Set.Make
    (existT _ _
      {|
        Compare.COMPARABLE.compare := (|Compare.Z|).(Compare.S.compare)
      |}).

Definition big_map_ids := (|Ids|).(S.SET.t).

Definition no_big_map_id : (|Ids|).(S.SET.t) := (|Ids|).(S.SET.empty).

Definition diff_of_big_map {A B : Set}
  (ctxt : Alpha_context.context)
  (fresh :
    Alpha_context.context ->
    Lwt.t
      (Error_monad.tzresult (Alpha_context.context * Alpha_context.Big_map.id)))
  (mode : unparsing_mode) (ids : (|Ids|).(S.SET.t))
  (function_parameter : Script_typed_ir.big_map A B)
  : Lwt.t
    (Error_monad.tzresult
      (list Alpha_context.Contract.big_map_diff_item * Alpha_context.Big_map.id
        * Alpha_context.context)) :=
  let '{|
    Script_typed_ir.big_map.id := id;
      Script_typed_ir.big_map.diff := diff;
      Script_typed_ir.big_map.key_type := key_type;
      Script_typed_ir.big_map.value_type := value_type
      |} := function_parameter in
  Error_monad.op_gtgteqquestion
    (Lwt.__return
      (Alpha_context.Gas.consume ctxt
        (Michelson_v1_gas.Cost_of.Legacy.map_to_list diff)))
    (fun ctxt =>
      Error_monad.op_gtgteqquestion
        match id with
        | Some id =>
          if (|Ids|).(S.SET.mem) id ids then
            Error_monad.op_gtgteqquestion (fresh ctxt)
              (fun function_parameter =>
                let '(ctxt, duplicate) := function_parameter in
                Error_monad.__return
                  (ctxt, [ Alpha_context.Contract.Copy id duplicate ], duplicate))
          else
            Error_monad.__return (ctxt, [], id)
        | None =>
          Error_monad.op_gtgteqquestion (fresh ctxt)
            (fun function_parameter =>
              let '(ctxt, id) := function_parameter in
              Error_monad.op_gtgteqquestion (unparse_ty ctxt key_type)
                (fun function_parameter =>
                  let '(kt, ctxt) := function_parameter in
                  Error_monad.op_gtgteqquestion (unparse_ty ctxt value_type)
                    (fun function_parameter =>
                      let '(kv, ctxt) := function_parameter in
                      Error_monad.__return
                        (ctxt,
                          [
                            Alpha_context.Contract.Alloc
                              {|
                                Alpha_context.Contract.big_map_diff_item.Alloc.big_map :=
                                  id;
                                Alpha_context.Contract.big_map_diff_item.Alloc.key_type :=
                                  Micheline.strip_locations
                                    kt;
                                Alpha_context.Contract.big_map_diff_item.Alloc.value_type :=
                                  Micheline.strip_locations
                                    kv
                                |}
                          ], id))))
        end
        (fun function_parameter =>
          let '(ctxt, init, big_map) := function_parameter in
          let pairs :=
            map_fold (fun key => fun value => fun acc => cons (key, value) acc)
              diff [] in
          Error_monad.op_gtgteqquestion
            (Error_monad.fold_left_s
              (fun function_parameter =>
                let '(acc, ctxt) := function_parameter in
                fun function_parameter =>
                  let '(key, value) := function_parameter in
                  Error_monad.op_gtgteqquestion
                    (Lwt.__return
                      (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
                    (fun ctxt =>
                      Error_monad.op_gtgteqquestion
                        (hash_data ctxt key_type key)
                        (fun function_parameter =>
                          let '(diff_key_hash, ctxt) := function_parameter in
                          Error_monad.op_gtgteqquestion
                            (unparse_data ctxt mode key_type key)
                            (fun function_parameter =>
                              let '(key_node, ctxt) := function_parameter in
                              let diff_key := Micheline.strip_locations key_node
                                in
                              Error_monad.op_gtgteqquestion
                                match value with
                                | None => Error_monad.__return (None, ctxt)
                                | Some x =>
                                  Error_monad.op_gtgteqquestion
                                    (unparse_data ctxt mode value_type x)
                                    (fun function_parameter =>
                                      let '(node, ctxt) := function_parameter in
                                      Error_monad.__return
                                        ((Some (Micheline.strip_locations node)),
                                          ctxt))
                                end
                                (fun function_parameter =>
                                  let '(diff_value, ctxt) := function_parameter
                                    in
                                  let diff_item :=
                                    Alpha_context.Contract.Update
                                      {|
                                        Alpha_context.Contract.big_map_diff_item.Update.big_map :=
                                          big_map;
                                        Alpha_context.Contract.big_map_diff_item.Update.diff_key :=
                                          diff_key;
                                        Alpha_context.Contract.big_map_diff_item.Update.diff_key_hash :=
                                          diff_key_hash;
                                        Alpha_context.Contract.big_map_diff_item.Update.diff_value :=
                                          diff_value |} in
                                  Error_monad.__return
                                    ((cons diff_item acc), ctxt)))))) ([], ctxt)
              pairs)
            (fun function_parameter =>
              let '(diff, ctxt) := function_parameter in
              Error_monad.__return ((Pervasives.op_at init diff), big_map, ctxt)))).

Fixpoint extract_big_map_updates {a : Set}
  (ctxt : Alpha_context.context)
  (fresh :
    Alpha_context.context ->
    Lwt.t
      (Error_monad.tzresult (Alpha_context.context * Alpha_context.Big_map.id)))
  (mode : unparsing_mode) (ids : (|Ids|).(S.SET.t))
  (acc : list Alpha_context.Contract.big_map_diff) (ty : Script_typed_ir.ty a)
  (x : a) {struct ctxt}
  : Lwt.t
    (Error_monad.tzresult
      (Alpha_context.context * a * (|Ids|).(S.SET.t) *
        list Alpha_context.Contract.big_map_diff)) :=
  match (ty, x) with
  | (Script_typed_ir.Big_map_t _ _ _, map) =>
    Error_monad.op_gtgteqquestion (diff_of_big_map ctxt fresh mode ids map)
      (fun function_parameter =>
        let '(diff, id, ctxt) := function_parameter in
        let Map := Script_typed_ir.big_map.diff map in
        let map :=
          Script_typed_ir.big_map.with_diff
            (empty_map (|Map|).(Script_typed_ir.Boxed_map.key_ty))
            (Script_typed_ir.big_map.with_id (Some id) map) in
        Error_monad.__return
          (ctxt, map, ((|Ids|).(S.SET.add) id ids), (cons diff acc)))
  | (Script_typed_ir.Pair_t (tyl, _, _) (tyr, _, _) _ true, (xl, xr)) =>
    Error_monad.op_gtgteqquestion
      (Lwt.__return (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
      (fun ctxt =>
        Error_monad.op_gtgteqquestion
          (extract_big_map_updates ctxt fresh mode ids acc tyl xl)
          (fun function_parameter =>
            let '(ctxt, xl, ids, acc) := function_parameter in
            Error_monad.op_gtgteqquestion
              (extract_big_map_updates ctxt fresh mode ids acc tyr xr)
              (fun function_parameter =>
                let '(ctxt, xr, ids, acc) := function_parameter in
                Error_monad.__return (ctxt, (xl, xr), ids, acc))))
  | (Script_typed_ir.Union_t (ty, _) (_, _) _ true, Script_typed_ir.L x) =>
    Error_monad.op_gtgteqquestion
      (Lwt.__return (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
      (fun ctxt =>
        Error_monad.op_gtgteqquestion
          (extract_big_map_updates ctxt fresh mode ids acc ty x)
          (fun function_parameter =>
            let '(ctxt, x, ids, acc) := function_parameter in
            Error_monad.__return (ctxt, (Script_typed_ir.L x), ids, acc)))
  | (Script_typed_ir.Union_t (_, _) (ty, _) _ true, Script_typed_ir.R x) =>
    Error_monad.op_gtgteqquestion
      (Lwt.__return (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
      (fun ctxt =>
        Error_monad.op_gtgteqquestion
          (extract_big_map_updates ctxt fresh mode ids acc ty x)
          (fun function_parameter =>
            let '(ctxt, x, ids, acc) := function_parameter in
            Error_monad.__return (ctxt, (Script_typed_ir.R x), ids, acc)))
  | (Script_typed_ir.Option_t ty _ true, Some x) =>
    Error_monad.op_gtgteqquestion
      (Lwt.__return (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
      (fun ctxt =>
        Error_monad.op_gtgteqquestion
          (extract_big_map_updates ctxt fresh mode ids acc ty x)
          (fun function_parameter =>
            let '(ctxt, x, ids, acc) := function_parameter in
            Error_monad.__return (ctxt, (Some x), ids, acc)))
  | (Script_typed_ir.List_t ty _ true, l) =>
    Error_monad.op_gtgteqquestion
      (Error_monad.fold_left_s
        (fun function_parameter =>
          let '(ctxt, l, ids, acc) := function_parameter in
          fun x =>
            Error_monad.op_gtgteqquestion
              (Lwt.__return
                (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
              (fun ctxt =>
                Error_monad.op_gtgteqquestion
                  (extract_big_map_updates ctxt fresh mode ids acc ty x)
                  (fun function_parameter =>
                    let '(ctxt, x, ids, acc) := function_parameter in
                    Error_monad.__return (ctxt, (cons x l), ids, acc))))
        (ctxt, [], ids, acc) l)
      (fun function_parameter =>
        let '(ctxt, l, ids, acc) := function_parameter in
        Error_monad.__return (ctxt, (List.rev l), ids, acc))
  | (Script_typed_ir.Map_t _ ty _ true, M as m) =>
    Error_monad.op_gtgteqquestion
      (Lwt.__return
        (Alpha_context.Gas.consume ctxt
          (Michelson_v1_gas.Cost_of.Legacy.map_to_list m)))
      (fun ctxt =>
        Error_monad.op_gtgteqquestion
          (Error_monad.fold_left_s
            (fun function_parameter =>
              let '(ctxt, m, ids, acc) := function_parameter in
              fun function_parameter =>
                let '(k, x) := function_parameter in
                Error_monad.op_gtgteqquestion
                  (Lwt.__return
                    (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
                  (fun ctxt =>
                    Error_monad.op_gtgteqquestion
                      (extract_big_map_updates ctxt fresh mode ids acc ty x)
                      (fun function_parameter =>
                        let '(ctxt, x, ids, acc) := function_parameter in
                        Error_monad.__return
                          (ctxt,
                            ((|M|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.add) k
                              x m), ids, acc))))
            (ctxt, (|M|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.empty), ids, acc)
            ((|M|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.bindings)
              (Pervasives.fst (|M|).(Script_typed_ir.Boxed_map.boxed))))
          (fun function_parameter =>
            let '(ctxt, m, ids, acc) := function_parameter in
            let M :=
              let OPS := (|M|).(Script_typed_ir.Boxed_map.OPS) in
              let key := (|M|).(Script_typed_ir.Boxed_map.key) in
              let value := (|M|).(Script_typed_ir.Boxed_map.value) in
              let key_ty := (|M|).(Script_typed_ir.Boxed_map.key_ty) in
              let boxed :=
                (m, (Pervasives.snd (|M|).(Script_typed_ir.Boxed_map.boxed))) in
              existT (fun _ => _) tt
                {|
                  Script_typed_ir.Boxed_map.key_ty := key_ty;
                  Script_typed_ir.Boxed_map.boxed := boxed
                |} in
            Error_monad.__return
              (ctxt,
                (existT _ _
                  {|
                    Script_typed_ir.Boxed_map.key_ty :=
                      (|M|).(Script_typed_ir.Boxed_map.key_ty);
                    Script_typed_ir.Boxed_map.boxed :=
                      (|M|).(Script_typed_ir.Boxed_map.boxed)
                  |}), ids, acc)))
  | (Script_typed_ir.Option_t _ _ true, None) =>
    Error_monad.__return (ctxt, None, ids, acc)
  | (Script_typed_ir.List_t _ _ false, v) =>
    Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Map_t _ _ _ false, v) =>
    Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Option_t _ _ false, None) =>
    Error_monad.__return (ctxt, None, ids, acc)
  | (Script_typed_ir.Pair_t _ _ _ false, v) =>
    Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Union_t _ _ _ false, v) =>
    Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Option_t _ _ false, v) =>
    Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Chain_id_t _, v) =>
    Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Set_t _ _, v) => Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Unit_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Int_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Nat_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Signature_t _, v) =>
    Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.String_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Bytes_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Mutez_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Key_hash_t _, v) =>
    Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Key_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Timestamp_t _, v) =>
    Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Address_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Bool_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Lambda_t _ _ _, v) =>
    Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Contract_t _ _, v) =>
    Error_monad.__return (ctxt, v, ids, acc)
  | (Script_typed_ir.Operation_t _, _) =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  end.

Definition collect_big_maps {A : Set}
  (ctxt : Alpha_context.context) (ty : Script_typed_ir.ty A) (x : A)
  : Lwt.t (Error_monad.tzresult ((|Ids|).(S.SET.t) * Alpha_context.context)) :=
  let fix collect {a : Set}
    (ctxt : Alpha_context.context) (ty : Script_typed_ir.ty a) (x : a)
    (acc : (|Ids|).(S.SET.t)) {struct ctxt}
    : Error_monad.tzresult ((|Ids|).(S.SET.t) * Alpha_context.context) :=
    match (ty, x) with
    |
      (Script_typed_ir.Big_map_t _ _ _, {|
        Script_typed_ir.big_map.id := Some id |}) =>
      Error_monad.op_gtgtquestion
        (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle)
        (fun ctxt => Error_monad.ok (((|Ids|).(S.SET.add) id acc), ctxt))
    | (Script_typed_ir.Pair_t (tyl, _, _) (tyr, _, _) _ true, (xl, xr)) =>
      Error_monad.op_gtgtquestion (collect ctxt tyl xl acc)
        (fun function_parameter =>
          let '(acc, ctxt) := function_parameter in
          collect ctxt tyr xr acc)
    | (Script_typed_ir.Union_t (ty, _) (_, _) _ true, Script_typed_ir.L x) =>
      collect ctxt ty x acc
    | (Script_typed_ir.Union_t (_, _) (ty, _) _ true, Script_typed_ir.R x) =>
      collect ctxt ty x acc
    | (Script_typed_ir.Option_t ty _ true, Some x) => collect ctxt ty x acc
    | (Script_typed_ir.List_t ty _ true, l) =>
      List.fold_left
        (fun acc =>
          fun x =>
            Error_monad.op_gtgtquestion acc
              (fun function_parameter =>
                let '(acc, ctxt) := function_parameter in
                collect ctxt ty x acc)) (Error_monad.ok (acc, ctxt)) l
    | (Script_typed_ir.Map_t _ ty _ true, m) =>
      map_fold
        (fun function_parameter =>
          let '_ := function_parameter in
          fun v =>
            fun acc =>
              Error_monad.op_gtgtquestion acc
                (fun function_parameter =>
                  let '(acc, ctxt) := function_parameter in
                  collect ctxt ty v acc)) m (Error_monad.ok (acc, ctxt))
    | (Script_typed_ir.List_t _ _ false, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Map_t _ _ _ false, _) => Error_monad.ok (acc, ctxt)
    |
      (Script_typed_ir.Big_map_t _ _ _, {| Script_typed_ir.big_map.id := None |})
      => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Option_t _ _ true, None) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Option_t _ _ false, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Union_t _ _ _ false, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Pair_t _ _ _ false, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Chain_id_t _, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Set_t _ _, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Unit_t _, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Int_t _, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Nat_t _, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Signature_t _, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.String_t _, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Bytes_t _, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Mutez_t _, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Key_hash_t _, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Key_t _, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Timestamp_t _, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Address_t _, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Bool_t _, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Lambda_t _ _ _, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Contract_t _ _, _) => Error_monad.ok (acc, ctxt)
    | (Script_typed_ir.Operation_t _, _) =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    end in
  Lwt.__return (collect ctxt ty x no_big_map_id).

Definition extract_big_map_diff {A : Set}
  (ctxt : Alpha_context.context) (mode : unparsing_mode) (temporary : bool)
  (to_duplicate : (|Ids|).(S.SET.t)) (to_update : (|Ids|).(S.SET.t))
  (ty : Script_typed_ir.ty A) (v : A)
  : Lwt.t
    (Error_monad.tzresult
      (A * option (list Alpha_context.Contract.big_map_diff_item) *
        Alpha_context.context)) :=
  let to_duplicate := (|Ids|).(S.SET.diff) to_duplicate to_update in
  let fresh :=
    if temporary then
      fun c => Error_monad.__return (Alpha_context.Big_map.fresh_temporary c)
    else
      Alpha_context.Big_map.fresh in
  Error_monad.op_gtgteqquestion
    (extract_big_map_updates ctxt fresh mode to_duplicate [] ty v)
    (fun function_parameter =>
      let '(ctxt, v, alive, diffs) := function_parameter in
      let diffs :=
        if temporary then
          diffs
        else
          let dead := (|Ids|).(S.SET.diff) to_update alive in
          cons
            ((|Ids|).(S.SET.fold)
              (fun id => fun acc => cons (Alpha_context.Contract.Clear id) acc)
              dead []) diffs in
      match diffs with
      | [] => Error_monad.__return (v, None, ctxt)
      | diffs => Error_monad.__return (v, (Some (List.flatten diffs)), ctxt)
      end).

Definition list_of_big_map_ids (ids : (|Ids|).(S.SET.t))
  : list (|Ids|).(S.SET.elt) := (|Ids|).(S.SET.elements) ids.

Script_ir_translator_mli

  • OCaml size: 272 lines
  • Coq size: 312 lines (+14% compared to OCaml)
script_ir_translator.mli 3 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Script_tc_errors

type ('ta, 'tb) eq = Eq : ('same, 'same) eq

type ex_comparable_ty =
  | Ex_comparable_ty : 'a Script_typed_ir.comparable_ty -> ex_comparable_ty

type ex_ty = Ex_ty : 'a Script_typed_ir.ty -> ex_ty

type ex_stack_ty = Ex_stack_ty : 'a Script_typed_ir.stack_ty -> ex_stack_ty

type ex_script = Ex_script : ('a, 'b) Script_typed_ir.script -> ex_script

type tc_context =
  | Lambda : tc_context
  | Dip : 'a Script_typed_ir.stack_ty * tc_context -> tc_context
  | Toplevel : {
      storage_type : 'sto Script_typed_ir.ty;
      param_type : 'param Script_typed_ir.ty;
      root_name : string option;
      legacy_create_contract_literal : bool;
    }
      -> tc_context

type 'bef judgement =
  | Typed : ('bef, 'aft) Script_typed_ir.descr -> 'bef judgement
  | Failed : {
      descr :
        'aft. 'aft Script_typed_ir.stack_ty ->
        ('bef, 'aft) Script_typed_ir.descr;
    }
      -> 'bef judgement

type unparsing_mode = Optimized | Readable

type type_logger =
  int ->
  (Script.expr * Script.annot) list ->
  (Script.expr * Script.annot) list ->
  unit

(* ---- Sets and Maps -------------------------------------------------------*)

val empty_set : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.set

val set_fold :
  ('elt -> 'acc -> 'acc) -> 'elt Script_typed_ir.set -> 'acc -> 'acc

val set_update : 'a -> bool -> 'a Script_typed_ir.set -> 'a Script_typed_ir.set

val set_mem : 'elt -> 'elt Script_typed_ir.set -> bool

val set_size : 'elt Script_typed_ir.set -> Script_int.n Script_int.num

val empty_map :
  'a Script_typed_ir.comparable_ty -> ('a, 'b) Script_typed_ir.map

val map_fold :
  ('key -> 'value -> 'acc -> 'acc) ->
  ('key, 'value) Script_typed_ir.map ->
  'acc ->
  'acc

val map_update :
  'a ->
  'b option ->
  ('a, 'b) Script_typed_ir.map ->
  ('a, 'b) Script_typed_ir.map

val map_mem : 'key -> ('key, 'value) Script_typed_ir.map -> bool

val map_get : 'key -> ('key, 'value) Script_typed_ir.map -> 'value option

val map_key_ty :
  ('a, 'b) Script_typed_ir.map -> 'a Script_typed_ir.comparable_ty

val map_size : ('a, 'b) Script_typed_ir.map -> Script_int.n Script_int.num

val empty_big_map :
  'a Script_typed_ir.comparable_ty ->
  'b Script_typed_ir.ty ->
  ('a, 'b) Script_typed_ir.big_map

val big_map_mem :
  context ->
  'key ->
  ('key, 'value) Script_typed_ir.big_map ->
  (bool * context) tzresult Lwt.t

val big_map_get :
  context ->
  'key ->
  ('key, 'value) Script_typed_ir.big_map ->
  ('value option * context) tzresult Lwt.t

val big_map_update :
  'key ->
  'value option ->
  ('key, 'value) Script_typed_ir.big_map ->
  ('key, 'value) Script_typed_ir.big_map

val ty_eq :
  context ->
  'ta Script_typed_ir.ty ->
  'tb Script_typed_ir.ty ->
  (('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq * context) tzresult

val compare_comparable : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> int

val parse_data :
  ?type_logger:type_logger ->
  context ->
  legacy:bool ->
  'a Script_typed_ir.ty ->
  Script.node ->
  ('a * context) tzresult Lwt.t

val unparse_data :
  context ->
  unparsing_mode ->
  'a Script_typed_ir.ty ->
  'a ->
  (Script.node * context) tzresult Lwt.t

val parse_instr :
  ?type_logger:type_logger ->
  tc_context ->
  context ->
  legacy:bool ->
  Script.node ->
  'bef Script_typed_ir.stack_ty ->
  ('bef judgement * context) tzresult Lwt.t

val parse_ty :
  context ->
  legacy:bool ->
  allow_big_map:bool ->
  allow_operation:bool ->
  allow_contract:bool ->
  Script.node ->
  (ex_ty * context) tzresult

val parse_packable_ty :
  context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult

val unparse_ty :
  context -> 'a Script_typed_ir.ty -> (Script.node * context) tzresult Lwt.t

val parse_toplevel :
  legacy:bool ->
  Script.expr ->
  (Script.node * Script.node * Script.node * string option) tzresult

val add_field_annot :
  [`Field_annot of string] option ->
  [`Var_annot of string] option ->
  Script.node ->
  Script.node

val typecheck_code :
  context -> Script.expr -> (type_map * context) tzresult Lwt.t

val typecheck_data :
  ?type_logger:type_logger ->
  context ->
  Script.expr * Script.expr ->
  context tzresult Lwt.t

val parse_script :
  ?type_logger:type_logger ->
  context ->
  legacy:bool ->
  Script.t ->
  (ex_script * context) tzresult Lwt.t

(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *)
val unparse_script :
  context ->
  unparsing_mode ->
  ('a, 'b) Script_typed_ir.script ->
  (Script.t * context) tzresult Lwt.t

val parse_contract :
  legacy:bool ->
  context ->
  Script.location ->
  'a Script_typed_ir.ty ->
  Contract.t ->
  entrypoint:string ->
  (context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t

val parse_contract_for_script :
  legacy:bool ->
  context ->
  Script.location ->
  'a Script_typed_ir.ty ->
  Contract.t ->
  entrypoint:string ->
  (context * 'a Script_typed_ir.typed_contract option) tzresult Lwt.t

val find_entrypoint :
  't Script_typed_ir.ty ->
  root_name:string option ->
  string ->
  ((Script.node -> Script.node) * ex_ty) tzresult

module Entrypoints_map : S.MAP with type key = string

val list_entrypoints :
  't Script_typed_ir.ty ->
  context ->
  root_name:string option ->
  ( Michelson_v1_primitives.prim list list
  * (Michelson_v1_primitives.prim list * Script.node) Entrypoints_map.t )
  tzresult

val pack_data :
  context -> 'a Script_typed_ir.ty -> 'a -> (MBytes.t * context) tzresult Lwt.t

val hash_data :
  context ->
  'a Script_typed_ir.ty ->
  'a ->
  (Script_expr_hash.t * context) tzresult Lwt.t

type big_map_ids

val no_big_map_id : big_map_ids

val collect_big_maps :
  context ->
  'a Script_typed_ir.ty ->
  'a ->
  (big_map_ids * context) tzresult Lwt.t

val list_of_big_map_ids : big_map_ids -> Z.t list

val extract_big_map_diff :
  context ->
  unparsing_mode ->
  temporary:bool ->
  to_duplicate:big_map_ids ->
  to_update:big_map_ids ->
  'a Script_typed_ir.ty ->
  'a ->
  ('a * Contract.big_map_diff option * context) tzresult Lwt.t
Script_ir_translator_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Michelson_v1_primitives.
Require Tezos.Script_expr_hash.
Require Tezos.Script_tc_errors.
Require Tezos.Script_typed_ir.

Reserved Notation "'eq".

Inductive eq_gadt : Set :=
| Eq : eq_gadt

where "'eq" := (fun (_ _ : Set) => eq_gadt).

Definition eq := 'eq.

Reserved Notation "'ex_comparable_ty".

Inductive ex_comparable_ty_gadt : Set :=
| Ex_comparable_ty : forall {a : Set},
  Script_typed_ir.comparable_ty a -> ex_comparable_ty_gadt

where "'ex_comparable_ty" := (ex_comparable_ty_gadt).

Definition ex_comparable_ty := 'ex_comparable_ty.

Reserved Notation "'ex_ty".

Inductive ex_ty_gadt : Set :=
| Ex_ty : forall {a : Set}, Script_typed_ir.ty a -> ex_ty_gadt

where "'ex_ty" := (ex_ty_gadt).

Definition ex_ty := 'ex_ty.

Reserved Notation "'ex_stack_ty".

Inductive ex_stack_ty_gadt : Set :=
| Ex_stack_ty : forall {a : Set}, Script_typed_ir.stack_ty a -> ex_stack_ty_gadt

where "'ex_stack_ty" := (ex_stack_ty_gadt).

Definition ex_stack_ty := 'ex_stack_ty.

Reserved Notation "'ex_script".

Inductive ex_script_gadt : Set :=
| Ex_script : forall {a b : Set}, Script_typed_ir.script a b -> ex_script_gadt

where "'ex_script" := (ex_script_gadt).

Definition ex_script := 'ex_script.

Module tc_context.
  Module Toplevel.
    Record record {storage_type param_type root_name
      legacy_create_contract_literal : Set} := {
      storage_type : storage_type;
      param_type : param_type;
      root_name : root_name;
      legacy_create_contract_literal : legacy_create_contract_literal }.
    Arguments record : clear implicits.
  End Toplevel.
  Definition Toplevel_skeleton := Toplevel.record.
End tc_context.

Reserved Notation "'tc_context.Toplevel".
Reserved Notation "'tc_context".

Inductive tc_context_gadt : Set :=
| Lambda : tc_context_gadt
| Dip : forall {a : Set},
  Script_typed_ir.stack_ty a -> tc_context_gadt -> tc_context_gadt
| Toplevel : forall {param sto : Set},
  'tc_context.Toplevel param sto -> tc_context_gadt

where "'tc_context" := (tc_context_gadt)
and "'tc_context.Toplevel" := (fun (t_param t_sto : Set) =>
  tc_context.Toplevel_skeleton (Script_typed_ir.ty t_sto)
    (Script_typed_ir.ty t_param) (option string) bool).

Module ConstructorRecordNotations_tc_context_gadt.
  Module tc_context.
    Definition Toplevel := 'tc_context.Toplevel.
  End tc_context.
End ConstructorRecordNotations_tc_context_gadt.
Import ConstructorRecordNotations_tc_context_gadt.

Definition tc_context := 'tc_context.

Module judgement.
  Module Failed.
    Record record {descr : Set} := {
      descr : descr }.
    Arguments record : clear implicits.
  End Failed.
  Definition Failed_skeleton := Failed.record.
End judgement.

Reserved Notation "'judgement.Failed".
Reserved Notation "'judgement".

Inductive judgement_gadt : Set :=
| Typed : forall {aft bef : Set},
  Script_typed_ir.descr bef aft -> judgement_gadt
| Failed : forall {aft bef : Set}, 'judgement.Failed aft bef -> judgement_gadt

where "'judgement" := (fun (_ : Set) => judgement_gadt)
and "'judgement.Failed" := (fun (t_aft t_bef : Set) =>
  judgement.Failed_skeleton
    ((Script_typed_ir.stack_ty t_aft -> Script_typed_ir.descr t_bef t_aft) *
      t_aft)).

Module ConstructorRecordNotations_judgement_gadt.
  Module judgement.
    Definition Failed := 'judgement.Failed.
  End judgement.
End ConstructorRecordNotations_judgement_gadt.
Import ConstructorRecordNotations_judgement_gadt.

Definition judgement := 'judgement.

Inductive unparsing_mode : Set :=
| Optimized : unparsing_mode
| Readable : unparsing_mode.

Definition type_logger :=
  Z -> list (Alpha_context.Script.expr * Alpha_context.Script.annot) ->
  list (Alpha_context.Script.expr * Alpha_context.Script.annot) -> unit.

Parameter empty_set : forall {a : Set},
  Script_typed_ir.comparable_ty a -> Script_typed_ir.set a.

Parameter set_fold : forall {acc elt : Set},
  (elt -> acc -> acc) -> Script_typed_ir.set elt -> acc -> acc.

Parameter set_update : forall {a : Set},
  a -> bool -> Script_typed_ir.set a -> Script_typed_ir.set a.

Parameter set_mem : forall {elt : Set}, elt -> Script_typed_ir.set elt -> bool.

Parameter set_size : forall {elt : Set},
  Script_typed_ir.set elt ->
  Alpha_context.Script_int.num Alpha_context.Script_int.n.

Parameter empty_map : forall {a b : Set},
  Script_typed_ir.comparable_ty a -> Script_typed_ir.map a b.

Parameter map_fold : forall {acc key value : Set},
  (key -> value -> acc -> acc) -> Script_typed_ir.map key value -> acc -> acc.

Parameter map_update : forall {a b : Set},
  a -> option b -> Script_typed_ir.map a b -> Script_typed_ir.map a b.

Parameter map_mem : forall {key value : Set},
  key -> Script_typed_ir.map key value -> bool.

Parameter map_get : forall {key value : Set},
  key -> Script_typed_ir.map key value -> option value.

Parameter map_key_ty : forall {a b : Set},
  Script_typed_ir.map a b -> Script_typed_ir.comparable_ty a.

Parameter map_size : forall {a b : Set},
  Script_typed_ir.map a b ->
  Alpha_context.Script_int.num Alpha_context.Script_int.n.

Parameter empty_big_map : forall {a b : Set},
  Script_typed_ir.comparable_ty a -> Script_typed_ir.ty b ->
  Script_typed_ir.big_map a b.

Parameter big_map_mem : forall {key value : Set},
  Alpha_context.context -> key -> Script_typed_ir.big_map key value ->
  Lwt.t (Error_monad.tzresult (bool * Alpha_context.context)).

Parameter big_map_get : forall {key value : Set},
  Alpha_context.context -> key -> Script_typed_ir.big_map key value ->
  Lwt.t (Error_monad.tzresult (option value * Alpha_context.context)).

Parameter big_map_update : forall {key value : Set},
  key -> option value -> Script_typed_ir.big_map key value ->
  Script_typed_ir.big_map key value.

Parameter ty_eq : forall {ta tb : Set},
  Alpha_context.context -> Script_typed_ir.ty ta -> Script_typed_ir.ty tb ->
  Error_monad.tzresult
    (eq (Script_typed_ir.ty ta) (Script_typed_ir.ty tb) * Alpha_context.context).

Parameter compare_comparable : forall {a : Set},
  Script_typed_ir.comparable_ty a -> a -> a -> Z.

Parameter parse_data : forall {a : Set},
  option type_logger -> Alpha_context.context -> bool -> Script_typed_ir.ty a ->
  Alpha_context.Script.node ->
  Lwt.t (Error_monad.tzresult (a * Alpha_context.context)).

Parameter unparse_data : forall {a : Set},
  Alpha_context.context -> unparsing_mode -> Script_typed_ir.ty a -> a ->
  Lwt.t
    (Error_monad.tzresult (Alpha_context.Script.node * Alpha_context.context)).

Parameter parse_instr : forall {bef : Set},
  option type_logger -> tc_context -> Alpha_context.context -> bool ->
  Alpha_context.Script.node -> Script_typed_ir.stack_ty bef ->
  Lwt.t (Error_monad.tzresult (judgement bef * Alpha_context.context)).

Parameter parse_ty :
  Alpha_context.context -> bool -> bool -> bool -> bool ->
  Alpha_context.Script.node ->
  Error_monad.tzresult (ex_ty * Alpha_context.context).

Parameter parse_packable_ty :
  Alpha_context.context -> bool -> Alpha_context.Script.node ->
  Error_monad.tzresult (ex_ty * Alpha_context.context).

Parameter unparse_ty : forall {a : Set},
  Alpha_context.context -> Script_typed_ir.ty a ->
  Lwt.t
    (Error_monad.tzresult (Alpha_context.Script.node * Alpha_context.context)).

Parameter parse_toplevel :
  bool -> Alpha_context.Script.expr ->
  Error_monad.tzresult
    (Alpha_context.Script.node * Alpha_context.Script.node *
      Alpha_context.Script.node * option string).

Parameter add_field_annot :
  option (* `Field_annot *) string -> option (* `Var_annot *) string ->
  Alpha_context.Script.node -> Alpha_context.Script.node.

Parameter typecheck_code :
  Alpha_context.context -> Alpha_context.Script.expr ->
  Lwt.t
    (Error_monad.tzresult (Script_tc_errors.type_map * Alpha_context.context)).

Parameter typecheck_data :
  option type_logger -> Alpha_context.context ->
  Alpha_context.Script.expr * Alpha_context.Script.expr ->
  Lwt.t (Error_monad.tzresult Alpha_context.context).

Parameter parse_script :
  option type_logger -> Alpha_context.context -> bool ->
  Alpha_context.Script.t ->
  Lwt.t (Error_monad.tzresult (ex_script * Alpha_context.context)).

Parameter unparse_script : forall {a b : Set},
  Alpha_context.context -> unparsing_mode -> Script_typed_ir.script a b ->
  Lwt.t (Error_monad.tzresult (Alpha_context.Script.t * Alpha_context.context)).

Parameter parse_contract : forall {a : Set},
  bool -> Alpha_context.context -> Alpha_context.Script.location ->
  Script_typed_ir.ty a -> Alpha_context.Contract.t -> string ->
  Lwt.t
    (Error_monad.tzresult
      (Alpha_context.context * Script_typed_ir.typed_contract a)).

Parameter parse_contract_for_script : forall {a : Set},
  bool -> Alpha_context.context -> Alpha_context.Script.location ->
  Script_typed_ir.ty a -> Alpha_context.Contract.t -> string ->
  Lwt.t
    (Error_monad.tzresult
      (Alpha_context.context * option (Script_typed_ir.typed_contract a))).

Parameter find_entrypoint : forall {t : Set},
  Script_typed_ir.ty t -> option string -> string ->
  Error_monad.tzresult
    ((Alpha_context.Script.node -> Alpha_context.Script.node) * ex_ty).

Parameter Entrypoints_map : {t : _ & S.MAP.signature string t}.

Parameter list_entrypoints : forall {t : Set},
  Script_typed_ir.ty t -> Alpha_context.context -> option string ->
  Error_monad.tzresult
    (list (list Michelson_v1_primitives.prim) *
      (|Entrypoints_map|).(S.MAP.t)
        (list Michelson_v1_primitives.prim * Alpha_context.Script.node)).

Parameter pack_data : forall {a : Set},
  Alpha_context.context -> Script_typed_ir.ty a -> a ->
  Lwt.t (Error_monad.tzresult (MBytes.t * Alpha_context.context)).

Parameter hash_data : forall {a : Set},
  Alpha_context.context -> Script_typed_ir.ty a -> a ->
  Lwt.t (Error_monad.tzresult (Script_expr_hash.t * Alpha_context.context)).

Parameter big_map_ids : Set.

Parameter no_big_map_id : big_map_ids.

Parameter collect_big_maps : forall {a : Set},
  Alpha_context.context -> Script_typed_ir.ty a -> a ->
  Lwt.t (Error_monad.tzresult (big_map_ids * Alpha_context.context)).

Parameter list_of_big_map_ids : big_map_ids -> list Z.t.

Parameter extract_big_map_diff : forall {a : Set},
  Alpha_context.context -> unparsing_mode -> bool -> big_map_ids ->
  big_map_ids -> Script_typed_ir.ty a -> a ->
  Lwt.t
    (Error_monad.tzresult
      (a * option Alpha_context.Contract.big_map_diff * Alpha_context.context)).

Script_repr

  • OCaml size: 233 lines
  • Coq size: 296 lines (+27% compared to OCaml)
script_repr.ml 4 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type location = Micheline.canonical_location

let location_encoding = Micheline.canonical_location_encoding

type annot = Micheline.annot

type expr = Michelson_v1_primitives.prim Micheline.canonical

type lazy_expr = expr Data_encoding.lazy_t

type node = (location, Michelson_v1_primitives.prim) Micheline.node

let expr_encoding =
  Micheline.canonical_encoding_v1
    ~variant:"michelson_v1"
    Michelson_v1_primitives.prim_encoding

type error += Lazy_script_decode (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"invalid_binary_format"
    ~title:"Invalid binary format"
    ~description:
      "Could not deserialize some piece of data from its binary representation"
    Data_encoding.empty
    (function Lazy_script_decode -> Some () | _ -> None)
    (fun () -> Lazy_script_decode)

let lazy_expr_encoding = Data_encoding.lazy_encoding expr_encoding

let lazy_expr expr = Data_encoding.make_lazy expr_encoding expr

type t = {code : lazy_expr; storage : lazy_expr}

let encoding =
  let open Data_encoding in
  def "scripted.contracts"
  @@ conv
       (fun {code; storage} -> (code, storage))
       (fun (code, storage) -> {code; storage})
       (obj2 (req "code" lazy_expr_encoding) (req "storage" lazy_expr_encoding))

let int_node_size_of_numbits n = (1, 1 + ((n + 63) / 64))

let int_node_size n = int_node_size_of_numbits (Z.numbits n)

let string_node_size_of_length s = (1, 1 + ((s + 7) / 8))

let string_node_size s = string_node_size_of_length (String.length s)

let bytes_node_size_of_length s =
  (* approx cost of indirection to the C heap *)
  (2, 1 + ((s + 7) / 8) + 12)

let bytes_node_size s = bytes_node_size_of_length (MBytes.length s)

let prim_node_size_nonrec_of_lengths n_args annots =
  let annots_length =
    List.fold_left (fun acc s -> acc + String.length s) 0 annots
  in
  if Compare.Int.(annots_length = 0) then (1 + n_args, 2 + (2 * n_args))
  else (2 + n_args, 4 + (2 * n_args) + ((annots_length + 7) / 8))

let prim_node_size_nonrec args annots =
  let n_args = List.length args in
  prim_node_size_nonrec_of_lengths n_args annots

let seq_node_size_nonrec_of_length n_args = (1 + n_args, 2 + (2 * n_args))

let seq_node_size_nonrec args =
  let n_args = List.length args in
  seq_node_size_nonrec_of_length n_args

let rec node_size node =
  let open Micheline in
  match node with
  | Int (_, n) ->
      int_node_size n
  | String (_, s) ->
      string_node_size s
  | Bytes (_, s) ->
      bytes_node_size s
  | Prim (_, _, args, annot) ->
      List.fold_left
        (fun (blocks, words) node ->
          let (nblocks, nwords) = node_size node in
          (blocks + nblocks, words + nwords))
        (prim_node_size_nonrec args annot)
        args
  | Seq (_, args) ->
      List.fold_left
        (fun (blocks, words) node ->
          let (nblocks, nwords) = node_size node in
          (blocks + nblocks, words + nwords))
        (seq_node_size_nonrec args)
        args

let expr_size expr = node_size (Micheline.root expr)

let traversal_cost node =
  let (blocks, _words) = node_size node in
  Gas_limit_repr.step_cost blocks

let cost_of_size (blocks, words) =
  let open Gas_limit_repr in
  (Compare.Int.max 0 (blocks - 1) *@ alloc_cost 0)
  +@ alloc_cost words +@ step_cost blocks

let node_cost node = cost_of_size (node_size node)

let int_node_cost n = cost_of_size (int_node_size n)

let int_node_cost_of_numbits n = cost_of_size (int_node_size_of_numbits n)

let string_node_cost s = cost_of_size (string_node_size s)

let string_node_cost_of_length s = cost_of_size (string_node_size_of_length s)

let bytes_node_cost s = cost_of_size (bytes_node_size s)

let bytes_node_cost_of_length s = cost_of_size (bytes_node_size_of_length s)

let prim_node_cost_nonrec args annot =
  cost_of_size (prim_node_size_nonrec args annot)

let prim_node_cost_nonrec_of_length n_args annot =
  cost_of_size (prim_node_size_nonrec_of_lengths n_args annot)

let seq_node_cost_nonrec args = cost_of_size (seq_node_size_nonrec args)

let seq_node_cost_nonrec_of_length n_args =
  cost_of_size (seq_node_size_nonrec_of_length n_args)

let deserialized_cost expr = cost_of_size (expr_size expr)

let serialized_cost bytes =
  let open Gas_limit_repr in
  alloc_mbytes_cost (MBytes.length bytes)

let force_decode lexpr =
  let account_deserialization_cost =
    Data_encoding.apply_lazy
      ~fun_value:(fun _ -> false)
      ~fun_bytes:(fun _ -> true)
      ~fun_combine:(fun _ _ -> false)
      lexpr
  in
  match Data_encoding.force_decode lexpr with
  | Some v ->
      if account_deserialization_cost then ok (v, deserialized_cost v)
      else ok (v, Gas_limit_repr.free)
  | None ->
      error Lazy_script_decode

let force_bytes expr =
  let open Gas_limit_repr in
  let account_serialization_cost =
    Data_encoding.apply_lazy
      ~fun_value:(fun v -> Some v)
      ~fun_bytes:(fun _ -> None)
      ~fun_combine:(fun _ _ -> None)
      expr
  in
  match Data_encoding.force_bytes expr with
  | bytes -> (
    match account_serialization_cost with
    | Some v ->
        ok (bytes, traversal_cost (Micheline.root v) +@ serialized_cost bytes)
    | None ->
        ok (bytes, Gas_limit_repr.free) )
  | exception _ ->
      error Lazy_script_decode

let minimal_deserialize_cost lexpr =
  Data_encoding.apply_lazy
    ~fun_value:(fun _ -> Gas_limit_repr.free)
    ~fun_bytes:(fun b -> serialized_cost b)
    ~fun_combine:(fun c_free _ -> c_free)
    lexpr

let unit =
  Micheline.strip_locations (Prim (0, Michelson_v1_primitives.D_Unit, [], []))

let unit_parameter = lazy_expr unit

let is_unit_parameter =
  let unit_bytes = Data_encoding.force_bytes unit_parameter in
  Data_encoding.apply_lazy
    ~fun_value:(fun v ->
      match Micheline.root v with
      | Prim (_, Michelson_v1_primitives.D_Unit, [], []) ->
          true
      | _ ->
          false)
    ~fun_bytes:(fun b -> MBytes.( = ) b unit_bytes)
    ~fun_combine:(fun res _ -> res)

let rec strip_annotations node =
  let open Micheline in
  match node with
  | (Int (_, _) | String (_, _) | Bytes (_, _)) as leaf ->
      leaf
  | Prim (loc, name, args, _) ->
      Prim (loc, name, List.map strip_annotations args, [])
  | Seq (loc, args) ->
      Seq (loc, List.map strip_annotations args)
Script_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Gas_limit_repr.
Require Tezos.Michelson_v1_primitives.

Definition location := Micheline.canonical_location.

Definition location_encoding
  : Data_encoding.encoding Micheline.canonical_location :=
  Micheline.canonical_location_encoding.

Definition annot := Micheline.annot.

Definition expr := Micheline.canonical Michelson_v1_primitives.prim.

Definition lazy_expr := Data_encoding.lazy_t expr.

Definition node := Micheline.node location Michelson_v1_primitives.prim.

Definition expr_encoding
  : Data_encoding.encoding (Micheline.canonical Michelson_v1_primitives.prim) :=
  Micheline.canonical_encoding_v1 "michelson_v1"
    Michelson_v1_primitives.prim_encoding.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition lazy_expr_encoding
  : Data_encoding.encoding
    (Data_encoding.lazy_t (Micheline.canonical Michelson_v1_primitives.prim)) :=
  Data_encoding.lazy_encoding expr_encoding.

Definition __lazy_expr_value
  (expr : Micheline.canonical Michelson_v1_primitives.prim)
  : Data_encoding.lazy_t (Micheline.canonical Michelson_v1_primitives.prim) :=
  Data_encoding.make_lazy expr_encoding expr.

Module t.
  Record record := Build {
    code : lazy_expr;
    storage : lazy_expr }.
  Definition with_code code (r : record) :=
    Build code r.(storage).
  Definition with_storage storage (r : record) :=
    Build r.(code) storage.
End t.
Definition t := t.record.

Definition encoding : Data_encoding.encoding t :=
  Pervasives.op_atat
    (let arg := Data_encoding.def "scripted.contracts" in
    fun eta => arg None None eta)
    (Data_encoding.conv
      (fun function_parameter =>
        let '{| t.code := code; t.storage := storage |} := function_parameter in
        (code, storage))
      (fun function_parameter =>
        let '(code, storage) := function_parameter in
        {| t.code := code; t.storage := storage |}) None
      (Data_encoding.obj2
        (Data_encoding.req None None "code" lazy_expr_encoding)
        (Data_encoding.req None None "storage" lazy_expr_encoding))).

Definition int_node_size_of_numbits (n : Z) : Z * Z :=
  (1, (Pervasives.op_plus 1 (Pervasives.op_div (Pervasives.op_plus n 63) 64))).

Definition int_node_size (n : Z.t) : Z * Z :=
  int_node_size_of_numbits (Z.numbits n).

Definition string_node_size_of_length (s : Z) : Z * Z :=
  (1, (Pervasives.op_plus 1 (Pervasives.op_div (Pervasives.op_plus s 7) 8))).

Definition string_node_size (s : string) : Z * Z :=
  string_node_size_of_length (String.length s).

Definition bytes_node_size_of_length (s : Z) : Z * Z :=
  (2,
    (Pervasives.op_plus
      (Pervasives.op_plus 1 (Pervasives.op_div (Pervasives.op_plus s 7) 8)) 12)).

Definition bytes_node_size (s : MBytes.t) : Z * Z :=
  bytes_node_size_of_length (MBytes.length s).

Definition prim_node_size_nonrec_of_lengths (n_args : Z) (annots : list string)
  : Z * Z :=
  let annots_length :=
    List.fold_left
      (fun acc => fun s => Pervasives.op_plus acc (String.length s)) 0 annots in
  if (|Compare.Int|).(Compare.S.op_eq) annots_length 0 then
    ((Pervasives.op_plus 1 n_args),
      (Pervasives.op_plus 2 (Pervasives.op_star 2 n_args)))
  else
    ((Pervasives.op_plus 2 n_args),
      (Pervasives.op_plus (Pervasives.op_plus 4 (Pervasives.op_star 2 n_args))
        (Pervasives.op_div (Pervasives.op_plus annots_length 7) 8))).

Definition prim_node_size_nonrec {A : Set}
  (args : list A) (annots : list string) : Z * Z :=
  let n_args := List.length args in
  prim_node_size_nonrec_of_lengths n_args annots.

Definition seq_node_size_nonrec_of_length (n_args : Z) : Z * Z :=
  ((Pervasives.op_plus 1 n_args),
    (Pervasives.op_plus 2 (Pervasives.op_star 2 n_args))).

Definition seq_node_size_nonrec {A : Set} (args : list A) : Z * Z :=
  let n_args := List.length args in
  seq_node_size_nonrec_of_length n_args.

Fixpoint node_size {A B : Set} (node : Micheline.node A B) {struct node}
  : Z * Z :=
  match node with
  | Micheline.Int _ n => int_node_size n
  | Micheline.String _ s => string_node_size s
  | Micheline.Bytes _ s => bytes_node_size s
  | Micheline.Prim _ _ args annot =>
    List.fold_left
      (fun function_parameter =>
        let '(blocks, words) := function_parameter in
        fun node =>
          let '(nblocks, nwords) := node_size node in
          ((Pervasives.op_plus blocks nblocks),
            (Pervasives.op_plus words nwords)))
      (prim_node_size_nonrec args annot) args
  | Micheline.Seq _ args =>
    List.fold_left
      (fun function_parameter =>
        let '(blocks, words) := function_parameter in
        fun node =>
          let '(nblocks, nwords) := node_size node in
          ((Pervasives.op_plus blocks nblocks),
            (Pervasives.op_plus words nwords))) (seq_node_size_nonrec args) args
  end.

Definition expr_size {A : Set} (expr : Micheline.canonical A) : Z * Z :=
  node_size (Micheline.root expr).

Definition traversal_cost {A B : Set} (node : Micheline.node A B)
  : Gas_limit_repr.cost :=
  let '(blocks, _words) := node_size node in
  Gas_limit_repr.step_cost blocks.

Definition cost_of_size (function_parameter : Z * Z) : Gas_limit_repr.cost :=
  let '(blocks, words) := function_parameter in
  Gas_limit_repr.op_plusat
    (Gas_limit_repr.op_plusat
      (Gas_limit_repr.op_starat
        ((|Compare.Int|).(Compare.S.max) 0 (Pervasives.op_minus blocks 1))
        (Gas_limit_repr.alloc_cost 0)) (Gas_limit_repr.alloc_cost words))
    (Gas_limit_repr.step_cost blocks).

Definition node_cost {A B : Set} (node : Micheline.node A B)
  : Gas_limit_repr.cost := cost_of_size (node_size node).

Definition int_node_cost (n : Z.t) : Gas_limit_repr.cost :=
  cost_of_size (int_node_size n).

Definition int_node_cost_of_numbits (n : Z) : Gas_limit_repr.cost :=
  cost_of_size (int_node_size_of_numbits n).

Definition string_node_cost (s : string) : Gas_limit_repr.cost :=
  cost_of_size (string_node_size s).

Definition string_node_cost_of_length (s : Z) : Gas_limit_repr.cost :=
  cost_of_size (string_node_size_of_length s).

Definition bytes_node_cost (s : MBytes.t) : Gas_limit_repr.cost :=
  cost_of_size (bytes_node_size s).

Definition bytes_node_cost_of_length (s : Z) : Gas_limit_repr.cost :=
  cost_of_size (bytes_node_size_of_length s).

Definition prim_node_cost_nonrec {A : Set} (args : list A) (annot : list string)
  : Gas_limit_repr.cost := cost_of_size (prim_node_size_nonrec args annot).

Definition prim_node_cost_nonrec_of_length (n_args : Z) (annot : list string)
  : Gas_limit_repr.cost :=
  cost_of_size (prim_node_size_nonrec_of_lengths n_args annot).

Definition seq_node_cost_nonrec {A : Set} (args : list A)
  : Gas_limit_repr.cost := cost_of_size (seq_node_size_nonrec args).

Definition seq_node_cost_nonrec_of_length (n_args : Z) : Gas_limit_repr.cost :=
  cost_of_size (seq_node_size_nonrec_of_length n_args).

Definition deserialized_cost {A : Set} (expr : Micheline.canonical A)
  : Gas_limit_repr.cost := cost_of_size (expr_size expr).

Definition serialized_cost (__bytes_value : MBytes.t) : Gas_limit_repr.cost :=
  Gas_limit_repr.alloc_mbytes_cost (MBytes.length __bytes_value).

Definition force_decode {A : Set}
  (lexpr : Data_encoding.lazy_t (Micheline.canonical A))
  : Error_monad.tzresult (Micheline.canonical A * Gas_limit_repr.cost) :=
  let account_deserialization_cost :=
    Data_encoding.apply_lazy
      (fun function_parameter =>
        let '_ := function_parameter in
        false)
      (fun function_parameter =>
        let '_ := function_parameter in
        true)
      (fun function_parameter =>
        let '_ := function_parameter in
        fun function_parameter =>
          let '_ := function_parameter in
          false) lexpr in
  match Data_encoding.force_decode lexpr with
  | Some v =>
    if account_deserialization_cost then
      Error_monad.ok (v, (deserialized_cost v))
    else
      Error_monad.ok (v, Gas_limit_repr.free)
  | None => Error_monad.__error_value extensible_type_value
  end.

Definition force_bytes {A : Set}
  (expr : Data_encoding.lazy_t (Micheline.canonical A))
  : Error_monad.tzresult (MBytes.t * Gas_limit_repr.cost) :=
  let account_serialization_cost :=
    Data_encoding.apply_lazy (fun v => Some v)
      (fun function_parameter =>
        let '_ := function_parameter in
        None)
      (fun function_parameter =>
        let '_ := function_parameter in
        fun function_parameter =>
          let '_ := function_parameter in
          None) expr in
  let '__bytes_value := Data_encoding.force_bytes expr in
  match account_serialization_cost with
  | Some v =>
    Error_monad.ok
      (__bytes_value,
        (Gas_limit_repr.op_plusat (traversal_cost (Micheline.root v))
          (serialized_cost __bytes_value)))
  | None => Error_monad.ok (__bytes_value, Gas_limit_repr.free)
  end.

Definition minimal_deserialize_cost {A : Set} (lexpr : Data_encoding.lazy_t A)
  : Gas_limit_repr.cost :=
  Data_encoding.apply_lazy
    (fun function_parameter =>
      let '_ := function_parameter in
      Gas_limit_repr.free) (fun b => serialized_cost b)
    (fun c_free =>
      fun function_parameter =>
        let '_ := function_parameter in
        c_free) lexpr.

Definition __unit_value : Micheline.canonical Michelson_v1_primitives.prim :=
  Micheline.strip_locations
    (Micheline.Prim 0 Michelson_v1_primitives.D_Unit [] []).

Definition unit_parameter
  : Data_encoding.lazy_t (Micheline.canonical Michelson_v1_primitives.prim) :=
  __lazy_expr_value __unit_value.

Definition is_unit_parameter
  : Data_encoding.lazy_t (Micheline.canonical Michelson_v1_primitives.prim) ->
  bool :=
  let unit_bytes := Data_encoding.force_bytes unit_parameter in
  Data_encoding.apply_lazy
    (fun v =>
      match Micheline.root v with
      | Micheline.Prim _ Michelson_v1_primitives.D_Unit [] [] => true
      | _ => false
      end) (fun b => MBytes.op_eq b unit_bytes)
    (fun res =>
      fun function_parameter =>
        let '_ := function_parameter in
        res).

Fixpoint strip_annotations {A B : Set} (node : Micheline.node A B) {struct node}
  : Micheline.node A B :=
  match node with
  | (Micheline.Int _ _ | Micheline.String _ _ | Micheline.Bytes _ _) as leaf =>
    leaf
  | Micheline.Prim loc name args _ =>
    Micheline.Prim loc name (List.map strip_annotations args) []
  | Micheline.Seq loc args =>
    Micheline.Seq loc (List.map strip_annotations args)
  end.

Script_repr_mli

  • OCaml size: 88 lines
  • Coq size: 89 lines (+1% compared to OCaml)
script_repr.mli 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type location = Micheline.canonical_location

type annot = Micheline.annot

type expr = Michelson_v1_primitives.prim Micheline.canonical

type error += Lazy_script_decode (* `Permanent *)

type lazy_expr = expr Data_encoding.lazy_t

type node = (location, Michelson_v1_primitives.prim) Micheline.node

val location_encoding : location Data_encoding.t

val expr_encoding : expr Data_encoding.t

val lazy_expr_encoding : lazy_expr Data_encoding.t

val lazy_expr : expr -> lazy_expr

type t = {code : lazy_expr; storage : lazy_expr}

val encoding : t Data_encoding.encoding

val deserialized_cost : expr -> Gas_limit_repr.cost

val serialized_cost : MBytes.t -> Gas_limit_repr.cost

val traversal_cost : node -> Gas_limit_repr.cost

val node_cost : node -> Gas_limit_repr.cost

val int_node_cost : Z.t -> Gas_limit_repr.cost

val int_node_cost_of_numbits : int -> Gas_limit_repr.cost

val string_node_cost : string -> Gas_limit_repr.cost

val string_node_cost_of_length : int -> Gas_limit_repr.cost

val bytes_node_cost : MBytes.t -> Gas_limit_repr.cost

val bytes_node_cost_of_length : int -> Gas_limit_repr.cost

val prim_node_cost_nonrec : expr list -> annot -> Gas_limit_repr.cost

val prim_node_cost_nonrec_of_length : int -> annot -> Gas_limit_repr.cost

val seq_node_cost_nonrec : expr list -> Gas_limit_repr.cost

val seq_node_cost_nonrec_of_length : int -> Gas_limit_repr.cost

val force_decode : lazy_expr -> (expr * Gas_limit_repr.cost) tzresult

val force_bytes : lazy_expr -> (MBytes.t * Gas_limit_repr.cost) tzresult

val minimal_deserialize_cost : lazy_expr -> Gas_limit_repr.cost

val unit_parameter : lazy_expr

val is_unit_parameter : lazy_expr -> bool

val strip_annotations : node -> node
Script_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Gas_limit_repr.
Require Tezos.Michelson_v1_primitives.

Definition location := Micheline.canonical_location.

Definition annot := Micheline.annot.

Definition expr := Micheline.canonical Michelson_v1_primitives.prim.

(* extensible_type error *)

Definition lazy_expr := Data_encoding.lazy_t expr.

Definition node := Micheline.node location Michelson_v1_primitives.prim.

Parameter location_encoding : Data_encoding.t location.

Parameter expr_encoding : Data_encoding.t expr.

Parameter lazy_expr_encoding : Data_encoding.t lazy_expr.

Parameter __lazy_expr_value : expr -> lazy_expr.

Module t.
  Record record := Build {
    code : lazy_expr;
    storage : lazy_expr }.
  Definition with_code code (r : record) :=
    Build code r.(storage).
  Definition with_storage storage (r : record) :=
    Build r.(code) storage.
End t.
Definition t := t.record.

Parameter encoding : Data_encoding.encoding t.

Parameter deserialized_cost : expr -> Gas_limit_repr.cost.

Parameter serialized_cost : MBytes.t -> Gas_limit_repr.cost.

Parameter traversal_cost : node -> Gas_limit_repr.cost.

Parameter node_cost : node -> Gas_limit_repr.cost.

Parameter int_node_cost : Z.t -> Gas_limit_repr.cost.

Parameter int_node_cost_of_numbits : Z -> Gas_limit_repr.cost.

Parameter string_node_cost : string -> Gas_limit_repr.cost.

Parameter string_node_cost_of_length : Z -> Gas_limit_repr.cost.

Parameter bytes_node_cost : MBytes.t -> Gas_limit_repr.cost.

Parameter bytes_node_cost_of_length : Z -> Gas_limit_repr.cost.

Parameter prim_node_cost_nonrec : list expr -> annot -> Gas_limit_repr.cost.

Parameter prim_node_cost_nonrec_of_length : Z -> annot -> Gas_limit_repr.cost.

Parameter seq_node_cost_nonrec : list expr -> Gas_limit_repr.cost.

Parameter seq_node_cost_nonrec_of_length : Z -> Gas_limit_repr.cost.

Parameter force_decode :
  lazy_expr -> Error_monad.tzresult (expr * Gas_limit_repr.cost).

Parameter force_bytes :
  lazy_expr -> Error_monad.tzresult (MBytes.t * Gas_limit_repr.cost).

Parameter minimal_deserialize_cost : lazy_expr -> Gas_limit_repr.cost.

Parameter unit_parameter : lazy_expr.

Parameter is_unit_parameter : lazy_expr -> bool.

Parameter strip_annotations : node -> node.

Script_tc_errors

  • OCaml size: 162 lines
  • Coq size: 173 lines (+6% compared to OCaml)
script_tc_errors.ml 46 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Script

(* ---- Error definitions ---------------------------------------------------*)

(* Auxiliary types for error documentation *)
type namespace =
  | Type_namespace
  | Constant_namespace
  | Instr_namespace
  | Keyword_namespace

type kind = Int_kind | String_kind | Bytes_kind | Prim_kind | Seq_kind

type unparsed_stack_ty = (Script.expr * Script.annot) list

type type_map = (int * (unparsed_stack_ty * unparsed_stack_ty)) list

(* Structure errors *)
type error += Invalid_arity of Script.location * prim * int * int

type error +=
  | Invalid_namespace of Script.location * prim * namespace * namespace

type error += Invalid_primitive of Script.location * prim list * prim

type error += Invalid_kind of Script.location * kind list * kind

type error += Missing_field of prim

type error += Duplicate_field of Script.location * prim

type error += Unexpected_big_map of Script.location

type error += Unexpected_operation of Script.location

type error += Unexpected_contract of Script.location

type error += No_such_entrypoint of string

type error += Duplicate_entrypoint of string

type error += Unreachable_entrypoint of prim list

type error += Entrypoint_name_too_long of string

(* Instruction typing errors *)
type error += Fail_not_in_tail_position of Script.location

type error +=
  | Undefined_binop :
      Script.location * prim * Script.expr * Script.expr
      -> error

type error += Undefined_unop : Script.location * prim * Script.expr -> error

type error +=
  | Bad_return : Script.location * unparsed_stack_ty * Script.expr -> error

type error +=
  | Bad_stack : Script.location * prim * int * unparsed_stack_ty -> error

type error +=
  | Unmatched_branches :
      Script.location * unparsed_stack_ty * unparsed_stack_ty
      -> error

type error += Self_in_lambda of Script.location

type error += Bad_stack_length

type error += Bad_stack_item of int

type error += Inconsistent_annotations of string * string

type error +=
  | Inconsistent_type_annotations :
      Script.location * Script.expr * Script.expr
      -> error

type error += Inconsistent_field_annotations of string * string

type error += Unexpected_annotation of Script.location

type error += Ungrouped_annotations of Script.location

type error += Invalid_map_body : Script.location * unparsed_stack_ty -> error

type error += Invalid_map_block_fail of Script.location

type error +=
  | Invalid_iter_body :
      Script.location * unparsed_stack_ty * unparsed_stack_ty
      -> error

type error += Type_too_large : Script.location * int * int -> error

(* Value typing errors *)
type error +=
  | Invalid_constant : Script.location * Script.expr * Script.expr -> error

type error +=
  | Invalid_syntactic_constant :
      Script.location * Script.expr * string
      -> error

type error += Invalid_contract of Script.location * Contract.t

type error += Invalid_big_map of Script.location * Big_map.id

type error +=
  | Comparable_type_expected : Script.location * Script.expr -> error

type error += Inconsistent_types : Script.expr * Script.expr -> error

type error += Unordered_map_keys of Script.location * Script.expr

type error += Unordered_set_values of Script.location * Script.expr

type error += Duplicate_map_keys of Script.location * Script.expr

type error += Duplicate_set_values of Script.location * Script.expr

(* Toplevel errors *)
type error +=
  | Ill_typed_data : string option * Script.expr * Script.expr -> error

type error +=
  | Ill_formed_type of string option * Script.expr * Script.location

type error += Ill_typed_contract : Script.expr * type_map -> error

(* Gas related errors *)
type error += Cannot_serialize_error

(* Deprecation errors *)
type error += Deprecated_instruction of prim
Script_tc_errors.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.

Import Alpha_context.

Import Script.

Inductive namespace : Set :=
| Type_namespace : namespace
| Constant_namespace : namespace
| Instr_namespace : namespace
| Keyword_namespace : namespace.

Inductive kind : Set :=
| Int_kind : kind
| String_kind : kind
| Bytes_kind : kind
| Prim_kind : kind
| Seq_kind : kind.

Definition unparsed_stack_ty :=
  list (Alpha_context.Script.expr * Alpha_context.Script.annot).

Definition type_map := list (Z * (unparsed_stack_ty * unparsed_stack_ty)).

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

Script_tc_errors_registration

  • OCaml size: 652 lines
  • Coq size: 54 lines (-92% compared to OCaml)
script_tc_errors_registration.ml 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Script
open Script_tc_errors

(* Helpers for encoding *)
let type_map_enc =
  let open Data_encoding in
  let stack_enc = list (tup2 Script.expr_encoding (list string)) in
  list
    (conv
       (fun (loc, (bef, aft)) -> (loc, bef, aft))
       (fun (loc, bef, aft) -> (loc, (bef, aft)))
       (obj3
          (req "location" Script.location_encoding)
          (req "stack_before" stack_enc)
          (req "stack_after" stack_enc)))

let stack_ty_enc =
  let open Data_encoding in
  list (obj2 (req "type" Script.expr_encoding) (dft "annots" (list string) []))

(* main registration *)
let () =
  let open Data_encoding in
  let located enc =
    merge_objs (obj1 (req "location" Script.location_encoding)) enc
  in
  let arity_enc = int8 in
  let namespace_enc =
    def
      "primitiveNamespace"
      ~title:"Primitive namespace"
      ~description:
        "One of the three possible namespaces of primitive (data constructor, \
         type name or instruction)."
    @@ string_enum
         [ ("type", Type_namespace);
           ("constant", Constant_namespace);
           ("instruction", Instr_namespace) ]
  in
  let kind_enc =
    def
      "expressionKind"
      ~title:"Expression kind"
      ~description:
        "One of the four possible kinds of expression (integer, string, \
         primitive application or sequence)."
    @@ string_enum
         [ ("integer", Int_kind);
           ("string", String_kind);
           ("bytes", Bytes_kind);
           ("primitiveApplication", Prim_kind);
           ("sequence", Seq_kind) ]
  in
  (* -- Structure errors ---------------------- *)
  (* Invalid arity *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_arity"
    ~title:"Invalid arity"
    ~description:
      "In a script or data expression, a primitive was applied to an \
       unsupported number of arguments."
    (located
       (obj3
          (req "primitive_name" Script.prim_encoding)
          (req "expected_arity" arity_enc)
          (req "wrong_arity" arity_enc)))
    (function
      | Invalid_arity (loc, name, exp, got) ->
          Some (loc, (name, exp, got))
      | _ ->
          None)
    (fun (loc, (name, exp, got)) -> Invalid_arity (loc, name, exp, got)) ;
  (* Missing field *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.missing_script_field"
    ~title:"Script is missing a field (parse error)"
    ~description:"When parsing script, a field was expected, but not provided"
    (obj1 (req "prim" prim_encoding))
    (function Missing_field prim -> Some prim | _ -> None)
    (fun prim -> Missing_field prim) ;
  (* Invalid primitive *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_primitive"
    ~title:"Invalid primitive"
    ~description:"In a script or data expression, a primitive was unknown."
    (located
       (obj2
          (dft "expected_primitive_names" (list prim_encoding) [])
          (req "wrong_primitive_name" prim_encoding)))
    (function
      | Invalid_primitive (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None)
    (fun (loc, (exp, got)) -> Invalid_primitive (loc, exp, got)) ;
  (* Invalid kind *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_expression_kind"
    ~title:"Invalid expression kind"
    ~description:
      "In a script or data expression, an expression was of the wrong kind \
       (for instance a string where only a primitive applications can appear)."
    (located
       (obj2 (req "expected_kinds" (list kind_enc)) (req "wrong_kind" kind_enc)))
    (function
      | Invalid_kind (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None)
    (fun (loc, (exp, got)) -> Invalid_kind (loc, exp, got)) ;
  (* Invalid namespace *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_primitive_namespace"
    ~title:"Invalid primitive namespace"
    ~description:
      "In a script or data expression, a primitive was of the wrong namespace."
    (located
       (obj3
          (req "primitive_name" prim_encoding)
          (req "expected_namespace" namespace_enc)
          (req "wrong_namespace" namespace_enc)))
    (function
      | Invalid_namespace (loc, name, exp, got) ->
          Some (loc, (name, exp, got))
      | _ ->
          None)
    (fun (loc, (name, exp, got)) -> Invalid_namespace (loc, name, exp, got)) ;
  (* Duplicate field *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.duplicate_script_field"
    ~title:"Script has a duplicated field (parse error)"
    ~description:"When parsing script, a field was found more than once"
    (obj2 (req "loc" location_encoding) (req "prim" prim_encoding))
    (function Duplicate_field (loc, prim) -> Some (loc, prim) | _ -> None)
    (fun (loc, prim) -> Duplicate_field (loc, prim)) ;
  (* Unexpected big_map *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unexpected_bigmap"
    ~title:"Big map in unauthorized position (type error)"
    ~description:
      "When parsing script, a big_map type was found in a position where it \
       could end up stored inside a big_map, which is forbidden for now."
    (obj1 (req "loc" location_encoding))
    (function Unexpected_big_map loc -> Some loc | _ -> None)
    (fun loc -> Unexpected_big_map loc) ;
  (* Unexpected operation *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unexpected_operation"
    ~title:"Operation in unauthorized position (type error)"
    ~description:
      "When parsing script, an operation type was found in the storage or \
       parameter field."
    (obj1 (req "loc" location_encoding))
    (function Unexpected_operation loc -> Some loc | _ -> None)
    (fun loc -> Unexpected_operation loc) ;
  (* No such entrypoint *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.no_such_entrypoint"
    ~title:"No such entrypoint (type error)"
    ~description:"An entrypoint was not found when calling a contract."
    (obj1 (req "entrypoint" string))
    (function No_such_entrypoint entrypoint -> Some entrypoint | _ -> None)
    (fun entrypoint -> No_such_entrypoint entrypoint) ;
  (* Unreachable entrypoint *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unreachable_entrypoint"
    ~title:"Unreachable entrypoint (type error)"
    ~description:"An entrypoint in the contract is not reachable."
    (obj1 (req "path" (list prim_encoding)))
    (function Unreachable_entrypoint path -> Some path | _ -> None)
    (fun path -> Unreachable_entrypoint path) ;
  (* Duplicate entrypoint *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.duplicate_entrypoint"
    ~title:"Duplicate entrypoint (type error)"
    ~description:"Two entrypoints have the same name."
    (obj1 (req "path" string))
    (function Duplicate_entrypoint entrypoint -> Some entrypoint | _ -> None)
    (fun entrypoint -> Duplicate_entrypoint entrypoint) ;
  (* Entrypoint name too long *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.entrypoint_name_too_long"
    ~title:"Entrypoint name too long (type error)"
    ~description:
      "An entrypoint name exceeds the maximum length of 31 characters."
    (obj1 (req "name" string))
    (function
      | Entrypoint_name_too_long entrypoint -> Some entrypoint | _ -> None)
    (fun entrypoint -> Entrypoint_name_too_long entrypoint) ;
  (* Unexpected contract *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unexpected_contract"
    ~title:"Contract in unauthorized position (type error)"
    ~description:
      "When parsing script, a contract type was found in the storage or \
       parameter field."
    (obj1 (req "loc" location_encoding))
    (function Unexpected_contract loc -> Some loc | _ -> None)
    (fun loc -> Unexpected_contract loc) ;
  (* -- Value typing errors ---------------------- *)
  (* Unordered map keys *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unordered_map_literal"
    ~title:"Invalid map key order"
    ~description:"Map keys must be in strictly increasing order"
    (obj2
       (req "location" Script.location_encoding)
       (req "item" Script.expr_encoding))
    (function Unordered_map_keys (loc, expr) -> Some (loc, expr) | _ -> None)
    (fun (loc, expr) -> Unordered_map_keys (loc, expr)) ;
  (* Duplicate map keys *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.duplicate_map_keys"
    ~title:"Duplicate map keys"
    ~description:"Map literals cannot contain duplicated keys"
    (obj2
       (req "location" Script.location_encoding)
       (req "item" Script.expr_encoding))
    (function Duplicate_map_keys (loc, expr) -> Some (loc, expr) | _ -> None)
    (fun (loc, expr) -> Duplicate_map_keys (loc, expr)) ;
  (* Unordered set values *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unordered_set_literal"
    ~title:"Invalid set value order"
    ~description:"Set values must be in strictly increasing order"
    (obj2
       (req "location" Script.location_encoding)
       (req "value" Script.expr_encoding))
    (function
      | Unordered_set_values (loc, expr) -> Some (loc, expr) | _ -> None)
    (fun (loc, expr) -> Unordered_set_values (loc, expr)) ;
  (* Duplicate set values *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.duplicate_set_values_in_literal"
    ~title:"Sets literals cannot contain duplicate elements"
    ~description:
      "Set literals cannot contain duplicate elements, but a duplicae was \
       found while parsing."
    (obj2
       (req "location" Script.location_encoding)
       (req "value" Script.expr_encoding))
    (function
      | Duplicate_set_values (loc, expr) -> Some (loc, expr) | _ -> None)
    (fun (loc, expr) -> Duplicate_set_values (loc, expr)) ;
  (* -- Instruction typing errors ------------- *)
  (* Fail not in tail position *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.fail_not_in_tail_position"
    ~title:"FAIL not in tail position"
    ~description:"There is non trivial garbage code after a FAIL instruction."
    (located empty)
    (function Fail_not_in_tail_position loc -> Some (loc, ()) | _ -> None)
    (fun (loc, ()) -> Fail_not_in_tail_position loc) ;
  (* Undefined binary operation *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.undefined_binop"
    ~title:"Undefined binop"
    ~description:
      "A binary operation is called on operands of types over which it is not \
       defined."
    (located
       (obj3
          (req "operator_name" prim_encoding)
          (req "wrong_left_operand_type" Script.expr_encoding)
          (req "wrong_right_operand_type" Script.expr_encoding)))
    (function
      | Undefined_binop (loc, n, tyl, tyr) ->
          Some (loc, (n, tyl, tyr))
      | _ ->
          None)
    (fun (loc, (n, tyl, tyr)) -> Undefined_binop (loc, n, tyl, tyr)) ;
  (* Undefined unary operation *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.undefined_unop"
    ~title:"Undefined unop"
    ~description:
      "A unary operation is called on an operand of type over which it is not \
       defined."
    (located
       (obj2
          (req "operator_name" prim_encoding)
          (req "wrong_operand_type" Script.expr_encoding)))
    (function Undefined_unop (loc, n, ty) -> Some (loc, (n, ty)) | _ -> None)
    (fun (loc, (n, ty)) -> Undefined_unop (loc, n, ty)) ;
  (* Bad return *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.bad_return"
    ~title:"Bad return"
    ~description:"Unexpected stack at the end of a lambda or script."
    (located
       (obj2
          (req "expected_return_type" Script.expr_encoding)
          (req "wrong_stack_type" stack_ty_enc)))
    (function Bad_return (loc, sty, ty) -> Some (loc, (ty, sty)) | _ -> None)
    (fun (loc, (ty, sty)) -> Bad_return (loc, sty, ty)) ;
  (* Bad stack *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.bad_stack"
    ~title:"Bad stack"
    ~description:"The stack has an unexpected length or contents."
    (located
       (obj3
          (req "primitive_name" prim_encoding)
          (req "relevant_stack_portion" int16)
          (req "wrong_stack_type" stack_ty_enc)))
    (function
      | Bad_stack (loc, name, s, sty) -> Some (loc, (name, s, sty)) | _ -> None)
    (fun (loc, (name, s, sty)) -> Bad_stack (loc, name, s, sty)) ;
  (* Inconsistent annotations *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.inconsistent_annotations"
    ~title:"Annotations inconsistent between branches"
    ~description:"The annotations on two types could not be merged"
    (obj2 (req "annot1" string) (req "annot2" string))
    (function
      | Inconsistent_annotations (annot1, annot2) ->
          Some (annot1, annot2)
      | _ ->
          None)
    (fun (annot1, annot2) -> Inconsistent_annotations (annot1, annot2)) ;
  (* Inconsistent field annotations *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.inconsistent_field_annotations"
    ~title:"Annotations for field accesses is inconsistent"
    ~description:
      "The specified field does not match the field annotation in the type"
    (obj2 (req "annot1" string) (req "annot2" string))
    (function
      | Inconsistent_field_annotations (annot1, annot2) ->
          Some (annot1, annot2)
      | _ ->
          None)
    (fun (annot1, annot2) -> Inconsistent_field_annotations (annot1, annot2)) ;
  (* Inconsistent type annotations *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.inconsistent_type_annotations"
    ~title:"Types contain inconsistent annotations"
    ~description:"The two types contain annotations that do not match"
    (located
       (obj2
          (req "type1" Script.expr_encoding)
          (req "type2" Script.expr_encoding)))
    (function
      | Inconsistent_type_annotations (loc, ty1, ty2) ->
          Some (loc, (ty1, ty2))
      | _ ->
          None)
    (fun (loc, (ty1, ty2)) -> Inconsistent_type_annotations (loc, ty1, ty2)) ;
  (* Unexpected annotation *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unexpected_annotation"
    ~title:"An annotation was encountered where no annotation is expected"
    ~description:"A node in the syntax tree was impropperly annotated"
    (located empty)
    (function Unexpected_annotation loc -> Some (loc, ()) | _ -> None)
    (fun (loc, ()) -> Unexpected_annotation loc) ;
  (* Ungrouped annotations *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.ungrouped_annotations"
    ~title:"Annotations of the same kind were found spread apart"
    ~description:"Annotations of the same kind must be grouped"
    (located empty)
    (function Ungrouped_annotations loc -> Some (loc, ()) | _ -> None)
    (fun (loc, ()) -> Ungrouped_annotations loc) ;
  (* Unmatched branches *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unmatched_branches"
    ~title:"Unmatched branches"
    ~description:
      "At the join point at the end of two code branches the stacks have \
       inconsistent lengths or contents."
    (located
       (obj2
          (req "first_stack_type" stack_ty_enc)
          (req "other_stack_type" stack_ty_enc)))
    (function
      | Unmatched_branches (loc, stya, styb) ->
          Some (loc, (stya, styb))
      | _ ->
          None)
    (fun (loc, (stya, styb)) -> Unmatched_branches (loc, stya, styb)) ;
  (* Bad stack item *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.bad_stack_item"
    ~title:"Bad stack item"
    ~description:
      "The type of a stack item is unexpected (this error is always \
       accompanied by a more precise one)."
    (obj1 (req "item_level" int16))
    (function Bad_stack_item n -> Some n | _ -> None)
    (fun n -> Bad_stack_item n) ;
  (* SELF in lambda *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.self_in_lambda"
    ~title:"SELF instruction in lambda"
    ~description:"A SELF instruction was encountered in a lambda expression."
    (located empty)
    (function Self_in_lambda loc -> Some (loc, ()) | _ -> None)
    (fun (loc, ()) -> Self_in_lambda loc) ;
  (* Bad stack length *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.inconsistent_stack_lengths"
    ~title:"Inconsistent stack lengths"
    ~description:
      "A stack was of an unexpected length (this error is always in the \
       context of a located error)."
    empty
    (function Bad_stack_length -> Some () | _ -> None)
    (fun () -> Bad_stack_length) ;
  (* -- Value typing errors ------------------- *)
  (* Invalid constant *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_constant"
    ~title:"Invalid constant"
    ~description:"A data expression was invalid for its expected type."
    (located
       (obj2
          (req "expected_type" Script.expr_encoding)
          (req "wrong_expression" Script.expr_encoding)))
    (function
      | Invalid_constant (loc, expr, ty) -> Some (loc, (ty, expr)) | _ -> None)
    (fun (loc, (ty, expr)) -> Invalid_constant (loc, expr, ty)) ;
  (* Invalid syntactic constant *)
  register_error_kind
    `Permanent
    ~id:"invalidSyntacticConstantError"
    ~title:"Invalid constant (parse error)"
    ~description:"A compile-time constant was invalid for its expected form."
    (located
       (obj2
          (req "expectedForm" Script.expr_encoding)
          (req "wrongExpression" Script.expr_encoding)))
    (function
      | Invalid_constant (loc, expr, ty) -> Some (loc, (ty, expr)) | _ -> None)
    (fun (loc, (ty, expr)) -> Invalid_constant (loc, expr, ty)) ;
  (* Invalid contract *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_contract"
    ~title:"Invalid contract"
    ~description:
      "A script or data expression references a contract that does not exist \
       or assumes a wrong type for an existing contract."
    (located (obj1 (req "contract" Contract.encoding)))
    (function Invalid_contract (loc, c) -> Some (loc, c) | _ -> None)
    (fun (loc, c) -> Invalid_contract (loc, c)) ;
  (* Invalid big_map *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_big_map"
    ~title:"Invalid big_map"
    ~description:
      "A script or data expression references a big_map that does not exist \
       or assumes a wrong type for an existing big_map."
    (located (obj1 (req "big_map" z)))
    (function Invalid_big_map (loc, c) -> Some (loc, c) | _ -> None)
    (fun (loc, c) -> Invalid_big_map (loc, c)) ;
  (* Comparable type expected *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.comparable_type_expected"
    ~title:"Comparable type expected"
    ~description:
      "A non comparable type was used in a place where only comparable types \
       are accepted."
    (located (obj1 (req "wrong_type" Script.expr_encoding)))
    (function
      | Comparable_type_expected (loc, ty) -> Some (loc, ty) | _ -> None)
    (fun (loc, ty) -> Comparable_type_expected (loc, ty)) ;
  (* Inconsistent types *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.inconsistent_types"
    ~title:"Inconsistent types"
    ~description:
      "This is the basic type clash error, that appears in several places \
       where the equality of two types have to be proven, it is always \
       accompanied with another error that provides more context."
    (obj2
       (req "first_type" Script.expr_encoding)
       (req "other_type" Script.expr_encoding))
    (function Inconsistent_types (tya, tyb) -> Some (tya, tyb) | _ -> None)
    (fun (tya, tyb) -> Inconsistent_types (tya, tyb)) ;
  (* -- Instruction typing errors ------------------- *)
  (* Invalid map body *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_map_body"
    ~title:"Invalid map body"
    ~description:"The body of a map block did not match the expected type"
    (obj2 (req "loc" Script.location_encoding) (req "body_type" stack_ty_enc))
    (function Invalid_map_body (loc, stack) -> Some (loc, stack) | _ -> None)
    (fun (loc, stack) -> Invalid_map_body (loc, stack)) ;
  (* Invalid map block FAIL *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_map_block_fail"
    ~title:"FAIL instruction occurred as body of map block"
    ~description:
      "FAIL cannot be the only instruction in the body. The propper type of \
       the return list cannot be inferred."
    (obj1 (req "loc" Script.location_encoding))
    (function Invalid_map_block_fail loc -> Some loc | _ -> None)
    (fun loc -> Invalid_map_block_fail loc) ;
  (* Invalid ITER body *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_iter_body"
    ~title:"ITER body returned wrong stack type"
    ~description:
      "The body of an ITER instruction must result in the same stack type as \
       before the ITER."
    (obj3
       (req "loc" Script.location_encoding)
       (req "bef_stack" stack_ty_enc)
       (req "aft_stack" stack_ty_enc))
    (function
      | Invalid_iter_body (loc, bef, aft) -> Some (loc, bef, aft) | _ -> None)
    (fun (loc, bef, aft) -> Invalid_iter_body (loc, bef, aft)) ;
  (* Type too large *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.type_too_large"
    ~title:"Stack item type too large"
    ~description:"An instruction generated a type larger than the limit."
    (obj3
       (req "loc" Script.location_encoding)
       (req "type_size" uint16)
       (req "maximum_type_size" uint16))
    (function
      | Type_too_large (loc, ts, maxts) -> Some (loc, ts, maxts) | _ -> None)
    (fun (loc, ts, maxts) -> Type_too_large (loc, ts, maxts)) ;
  (* -- Toplevel errors ------------------- *)
  (* Ill typed data *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.ill_typed_data"
    ~title:"Ill typed data"
    ~description:
      "The toplevel error thrown when trying to typecheck a data expression \
       against a given type (always followed by more precise errors)."
    (obj3
       (opt "identifier" string)
       (req "expected_type" Script.expr_encoding)
       (req "ill_typed_expression" Script.expr_encoding))
    (function
      | Ill_typed_data (name, expr, ty) -> Some (name, ty, expr) | _ -> None)
    (fun (name, ty, expr) -> Ill_typed_data (name, expr, ty)) ;
  (* Ill formed type *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.ill_formed_type"
    ~title:"Ill formed type"
    ~description:
      "The toplevel error thrown when trying to parse a type expression \
       (always followed by more precise errors)."
    (obj3
       (opt "identifier" string)
       (req "ill_formed_expression" Script.expr_encoding)
       (req "location" Script.location_encoding))
    (function
      | Ill_formed_type (name, expr, loc) -> Some (name, expr, loc) | _ -> None)
    (fun (name, expr, loc) -> Ill_formed_type (name, expr, loc)) ;
  (* Ill typed contract *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.ill_typed_contract"
    ~title:"Ill typed contract"
    ~description:
      "The toplevel error thrown when trying to typecheck a contract code \
       against given input, output and storage types (always followed by more \
       precise errors)."
    (obj2
       (req "ill_typed_code" Script.expr_encoding)
       (req "type_map" type_map_enc))
    (function
      | Ill_typed_contract (expr, type_map) ->
          Some (expr, type_map)
      | _ ->
          None)
    (fun (expr, type_map) -> Ill_typed_contract (expr, type_map)) ;
  (* Cannot serialize error *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.cannot_serialize_error"
    ~title:"Not enough gas to serialize error"
    ~description:"The error was too big to be serialized with the provided gas"
    Data_encoding.empty
    (function Cannot_serialize_error -> Some () | _ -> None)
    (fun () -> Cannot_serialize_error) ;
  (* Deprecated instruction *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.deprecated_instruction"
    ~title:"Script is using a deprecated instruction"
    ~description:
      "A deprecated instruction usage is disallowed in newly created contracts"
    (obj1 (req "prim" prim_encoding))
    (function Deprecated_instruction prim -> Some prim | _ -> None)
    (fun prim -> Deprecated_instruction prim)
Script_tc_errors_registration.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.

Import Alpha_context.

Import Script.

Import Script_tc_errors.

Definition type_map_enc
  : Data_encoding.encoding
    (list
      (Alpha_context.Script.location *
        (list (Alpha_context.Script.expr * list string) *
          list (Alpha_context.Script.expr * list string)))) :=
  let stack_enc :=
    Data_encoding.__list_value None
      (Data_encoding.tup2 Alpha_context.Script.expr_encoding
        (Data_encoding.__list_value None Data_encoding.__string_value)) in
  Data_encoding.__list_value None
    (Data_encoding.conv
      (fun function_parameter =>
        let '(loc, (bef, aft)) := function_parameter in
        (loc, bef, aft))
      (fun function_parameter =>
        let '(loc, bef, aft) := function_parameter in
        (loc, (bef, aft))) None
      (Data_encoding.obj3
        (Data_encoding.req None None "location"
          Alpha_context.Script.location_encoding)
        (Data_encoding.req None None "stack_before" stack_enc)
        (Data_encoding.req None None "stack_after" stack_enc))).

Definition stack_ty_enc
  : Data_encoding.encoding (list (Alpha_context.Script.expr * list string)) :=
  Data_encoding.__list_value None
    (Data_encoding.obj2
      (Data_encoding.req None None "type" Alpha_context.Script.expr_encoding)
      (Data_encoding.dft None None "annots"
        (Data_encoding.__list_value None Data_encoding.__string_value) [])).

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Script_timestamp_repr

  • OCaml size: 57 lines
  • Coq size: 58 lines (+1% compared to OCaml)
script_timestamp_repr.ml 2 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Z.t

let compare = Z.compare

let of_int64 = Z.of_int64

let of_string x =
  match Time_repr.of_notation x with
  | None -> (
    try Some (Z.of_string x) with _ -> None )
  | Some time ->
      Some (of_int64 (Time_repr.to_seconds time))

let to_notation x =
  try
    let notation = Time_repr.to_notation (Time.of_seconds (Z.to_int64 x)) in
    if String.equal notation "out_of_range" then None else Some notation
  with _ -> None

let to_num_str = Z.to_string

let to_string x = match to_notation x with None -> to_num_str x | Some s -> s

let diff x y = Script_int_repr.of_zint @@ Z.sub x y

let sub_delta t delta = Z.sub t (Script_int_repr.to_zint delta)

let add_delta t delta = Z.add t (Script_int_repr.to_zint delta)

let to_zint x = x

let of_zint x = x
Script_timestamp_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Script_int_repr.
Require Tezos.Time_repr.

Definition t := Z.t.

Definition compare : Z.t -> Z.t -> Z := Z.compare.

Definition of_int64 : int64 -> Z.t := Z.of_int64.

Definition of_string (x : string) : option Z.t :=
  match Time_repr.of_notation x with
  | None =>
    (* ❌ Try-with are not handled *)
    try (Some (Z.of_string x))
  | Some time => Some (of_int64 (Time_repr.to_seconds time))
  end.

Definition to_notation (x : Z.t) : option string :=
  (* ❌ Try-with are not handled *)
  try
    (let notation := Time_repr.to_notation (Time.of_seconds (Z.to_int64 x)) in
    if String.equal notation "out_of_range" then
      None
    else
      Some notation).

Definition to_num_str : Z.t -> string := Z.to_string.

Definition to_string (x : Z.t) : string :=
  match to_notation x with
  | None => to_num_str x
  | Some s => s
  end.

Definition diff (x : Z.t) (y : Z.t) : Script_int_repr.num Script_int_repr.z :=
  Pervasives.op_atat Script_int_repr.of_zint (Z.sub x y).

Definition sub_delta {A : Set} (__t_value : Z.t) (delta : Script_int_repr.num A)
  : Z.t := Z.sub __t_value (Script_int_repr.to_zint delta).

Definition add_delta {A : Set} (__t_value : Z.t) (delta : Script_int_repr.num A)
  : Z.t := Z.add __t_value (Script_int_repr.to_zint delta).

Definition to_zint {A : Set} (x : A) : A := x.

Definition of_zint {A : Set} (x : A) : A := x.

Script_timestamp_repr_mli

  • OCaml size: 53 lines
  • Coq size: 37 lines (-31% compared to OCaml)
script_timestamp_repr.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Script_int_repr

type t

val of_int64 : int64 -> t

val compare : t -> t -> int

(* Convert a timestamp to a notation if possible *)
val to_notation : t -> string option

(* Convert a timestamp to a string representation of the seconds *)
val to_num_str : t -> string

(* Convert to a notation if possible, or num if not *)
val to_string : t -> string

val of_string : string -> t option

val diff : t -> t -> z num

val add_delta : t -> z num -> t

val sub_delta : t -> z num -> t

val to_zint : t -> Z.t

val of_zint : Z.t -> t
Script_timestamp_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Script_int_repr.

Parameter t : Set.

Parameter of_int64 : int64 -> t.

Parameter compare : t -> t -> Z.

Parameter to_notation : t -> option string.

Parameter to_num_str : t -> string.

Parameter to_string : t -> string.

Parameter of_string : string -> option t.

Parameter diff : t -> t -> Script_int_repr.num Script_int_repr.z.

Parameter add_delta : t -> Script_int_repr.num Script_int_repr.z -> t.

Parameter sub_delta : t -> Script_int_repr.num Script_int_repr.z -> t.

Parameter to_zint : t -> Z.t.

Parameter of_zint : Z.t -> t.

Script_typed_ir

  • OCaml size: 422 lines
  • Coq size: 428 lines (+1% compared to OCaml)
script_typed_ir.ml 4 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Script_int

(* ---- Auxiliary types -----------------------------------------------------*)

type var_annot = [`Var_annot of string]

type type_annot = [`Type_annot of string]

type field_annot = [`Field_annot of string]

type annot = [var_annot | type_annot | field_annot]

type address = Contract.t * string

type ('a, 'b) pair = 'a * 'b

type ('a, 'b) union = L of 'a | R of 'b

type comb = Comb

type leaf = Leaf

type (_, _) comparable_struct =
  | Int_key : type_annot option -> (z num, _) comparable_struct
  | Nat_key : type_annot option -> (n num, _) comparable_struct
  | String_key : type_annot option -> (string, _) comparable_struct
  | Bytes_key : type_annot option -> (MBytes.t, _) comparable_struct
  | Mutez_key : type_annot option -> (Tez.t, _) comparable_struct
  | Bool_key : type_annot option -> (bool, _) comparable_struct
  | Key_hash_key : type_annot option -> (public_key_hash, _) comparable_struct
  | Timestamp_key :
      type_annot option
      -> (Script_timestamp.t, _) comparable_struct
  | Address_key : type_annot option -> (address, _) comparable_struct
  | Pair_key :
      (('a, leaf) comparable_struct * field_annot option)
      * (('b, _) comparable_struct * field_annot option)
      * type_annot option
      -> (('a, 'b) pair, comb) comparable_struct

type 'a comparable_ty = ('a, comb) comparable_struct

module type Boxed_set = sig
  type elt

  val elt_ty : elt comparable_ty

  module OPS : S.SET with type elt = elt

  val boxed : OPS.t

  val size : int
end

type 'elt set = (module Boxed_set with type elt = 'elt)

module type Boxed_map = sig
  type key

  type value

  val key_ty : key comparable_ty

  module OPS : S.MAP with type key = key

  val boxed : value OPS.t * int
end

type ('key, 'value) map =
  (module Boxed_map with type key = 'key and type value = 'value)

type operation = packed_internal_operation * Contract.big_map_diff option

type ('arg, 'storage) script = {
  code : (('arg, 'storage) pair, (operation list, 'storage) pair) lambda;
  arg_type : 'arg ty;
  storage : 'storage;
  storage_type : 'storage ty;
  root_name : string option;
}

and end_of_stack = unit

and ('arg, 'ret) lambda =
  | Lam :
      ('arg * end_of_stack, 'ret * end_of_stack) descr * Script.node
      -> ('arg, 'ret) lambda

and 'arg typed_contract = 'arg ty * address

and 'ty ty =
  | Unit_t : type_annot option -> unit ty
  | Int_t : type_annot option -> z num ty
  | Nat_t : type_annot option -> n num ty
  | Signature_t : type_annot option -> signature ty
  | String_t : type_annot option -> string ty
  | Bytes_t : type_annot option -> MBytes.t ty
  | Mutez_t : type_annot option -> Tez.t ty
  | Key_hash_t : type_annot option -> public_key_hash ty
  | Key_t : type_annot option -> public_key ty
  | Timestamp_t : type_annot option -> Script_timestamp.t ty
  | Address_t : type_annot option -> address ty
  | Bool_t : type_annot option -> bool ty
  | Pair_t :
      ('a ty * field_annot option * var_annot option)
      * ('b ty * field_annot option * var_annot option)
      * type_annot option
      * bool
      -> ('a, 'b) pair ty
  | Union_t :
      ('a ty * field_annot option)
      * ('b ty * field_annot option)
      * type_annot option
      * bool
      -> ('a, 'b) union ty
  | Lambda_t : 'arg ty * 'ret ty * type_annot option -> ('arg, 'ret) lambda ty
  | Option_t : 'v ty * type_annot option * bool -> 'v option ty
  | List_t : 'v ty * type_annot option * bool -> 'v list ty
  | Set_t : 'v comparable_ty * type_annot option -> 'v set ty
  | Map_t :
      'k comparable_ty * 'v ty * type_annot option * bool
      -> ('k, 'v) map ty
  | Big_map_t :
      'k comparable_ty * 'v ty * type_annot option
      -> ('k, 'v) big_map ty
  | Contract_t : 'arg ty * type_annot option -> 'arg typed_contract ty
  | Operation_t : type_annot option -> operation ty
  | Chain_id_t : type_annot option -> Chain_id.t ty

and 'ty stack_ty =
  | Item_t :
      'ty ty * 'rest stack_ty * var_annot option
      -> ('ty * 'rest) stack_ty
  | Empty_t : end_of_stack stack_ty

and ('key, 'value) big_map = {
  id : Z.t option;
  diff : ('key, 'value option) map;
  key_type : 'key ty;
  value_type : 'value ty;
}

(* ---- Instructions --------------------------------------------------------*)

(* The low-level, typed instructions, as a GADT whose parameters
   encode the typing rules.

   The left parameter is the typed shape of the stack before the
   instruction, the right one the shape after. Any program whose
   construction is accepted by OCaml's type-checker is guaranteed to
   be type-safe. Overloadings of the concrete syntax are already
   resolved in this representation, either by using different
   constructors or type witness parameters. *)
and ('bef, 'aft) instr =
  (* stack ops *)
  | Drop : (_ * 'rest, 'rest) instr
  | Dup : ('top * 'rest, 'top * ('top * 'rest)) instr
  | Swap : ('tip * ('top * 'rest), 'top * ('tip * 'rest)) instr
  | Const : 'ty -> ('rest, 'ty * 'rest) instr
  (* pairs *)
  | Cons_pair : ('car * ('cdr * 'rest), ('car, 'cdr) pair * 'rest) instr
  | Car : (('car, _) pair * 'rest, 'car * 'rest) instr
  | Cdr : ((_, 'cdr) pair * 'rest, 'cdr * 'rest) instr
  (* options *)
  | Cons_some : ('v * 'rest, 'v option * 'rest) instr
  | Cons_none : 'a ty -> ('rest, 'a option * 'rest) instr
  | If_none :
      ('bef, 'aft) descr * ('a * 'bef, 'aft) descr
      -> ('a option * 'bef, 'aft) instr
  (* unions *)
  | Left : ('l * 'rest, ('l, 'r) union * 'rest) instr
  | Right : ('r * 'rest, ('l, 'r) union * 'rest) instr
  | If_left :
      ('l * 'bef, 'aft) descr * ('r * 'bef, 'aft) descr
      -> (('l, 'r) union * 'bef, 'aft) instr
  (* lists *)
  | Cons_list : ('a * ('a list * 'rest), 'a list * 'rest) instr
  | Nil : ('rest, 'a list * 'rest) instr
  | If_cons :
      ('a * ('a list * 'bef), 'aft) descr * ('bef, 'aft) descr
      -> ('a list * 'bef, 'aft) instr
  | List_map :
      ('a * 'rest, 'b * 'rest) descr
      -> ('a list * 'rest, 'b list * 'rest) instr
  | List_iter : ('a * 'rest, 'rest) descr -> ('a list * 'rest, 'rest) instr
  | List_size : ('a list * 'rest, n num * 'rest) instr
  (* sets *)
  | Empty_set : 'a comparable_ty -> ('rest, 'a set * 'rest) instr
  | Set_iter : ('a * 'rest, 'rest) descr -> ('a set * 'rest, 'rest) instr
  | Set_mem : ('elt * ('elt set * 'rest), bool * 'rest) instr
  | Set_update : ('elt * (bool * ('elt set * 'rest)), 'elt set * 'rest) instr
  | Set_size : ('a set * 'rest, n num * 'rest) instr
  (* maps *)
  | Empty_map : 'a comparable_ty * 'v ty -> ('rest, ('a, 'v) map * 'rest) instr
  | Map_map :
      (('a * 'v) * 'rest, 'r * 'rest) descr
      -> (('a, 'v) map * 'rest, ('a, 'r) map * 'rest) instr
  | Map_iter :
      (('a * 'v) * 'rest, 'rest) descr
      -> (('a, 'v) map * 'rest, 'rest) instr
  | Map_mem : ('a * (('a, 'v) map * 'rest), bool * 'rest) instr
  | Map_get : ('a * (('a, 'v) map * 'rest), 'v option * 'rest) instr
  | Map_update
      : ('a * ('v option * (('a, 'v) map * 'rest)), ('a, 'v) map * 'rest) instr
  | Map_size : (('a, 'b) map * 'rest, n num * 'rest) instr
  (* big maps *)
  | Empty_big_map :
      'a comparable_ty * 'v ty
      -> ('rest, ('a, 'v) big_map * 'rest) instr
  | Big_map_mem : ('a * (('a, 'v) big_map * 'rest), bool * 'rest) instr
  | Big_map_get : ('a * (('a, 'v) big_map * 'rest), 'v option * 'rest) instr
  | Big_map_update
      : ( 'key * ('value option * (('key, 'value) big_map * 'rest)),
          ('key, 'value) big_map * 'rest )
        instr
  (* string operations *)
  | Concat_string : (string list * 'rest, string * 'rest) instr
  | Concat_string_pair : (string * (string * 'rest), string * 'rest) instr
  | Slice_string
      : (n num * (n num * (string * 'rest)), string option * 'rest) instr
  | String_size : (string * 'rest, n num * 'rest) instr
  (* bytes operations *)
  | Concat_bytes : (MBytes.t list * 'rest, MBytes.t * 'rest) instr
  | Concat_bytes_pair : (MBytes.t * (MBytes.t * 'rest), MBytes.t * 'rest) instr
  | Slice_bytes
      : (n num * (n num * (MBytes.t * 'rest)), MBytes.t option * 'rest) instr
  | Bytes_size : (MBytes.t * 'rest, n num * 'rest) instr
  (* timestamp operations *)
  | Add_seconds_to_timestamp
      : ( z num * (Script_timestamp.t * 'rest),
          Script_timestamp.t * 'rest )
        instr
  | Add_timestamp_to_seconds
      : ( Script_timestamp.t * (z num * 'rest),
          Script_timestamp.t * 'rest )
        instr
  | Sub_timestamp_seconds
      : ( Script_timestamp.t * (z num * 'rest),
          Script_timestamp.t * 'rest )
        instr
  | Diff_timestamps
      : ( Script_timestamp.t * (Script_timestamp.t * 'rest),
          z num * 'rest )
        instr
  (* tez operations *)
  | Add_tez : (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr
  | Sub_tez : (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr
  | Mul_teznat : (Tez.t * (n num * 'rest), Tez.t * 'rest) instr
  | Mul_nattez : (n num * (Tez.t * 'rest), Tez.t * 'rest) instr
  | Ediv_teznat
      : (Tez.t * (n num * 'rest), (Tez.t, Tez.t) pair option * 'rest) instr
  | Ediv_tez
      : (Tez.t * (Tez.t * 'rest), (n num, Tez.t) pair option * 'rest) instr
  (* boolean operations *)
  | Or : (bool * (bool * 'rest), bool * 'rest) instr
  | And : (bool * (bool * 'rest), bool * 'rest) instr
  | Xor : (bool * (bool * 'rest), bool * 'rest) instr
  | Not : (bool * 'rest, bool * 'rest) instr
  (* integer operations *)
  | Is_nat : (z num * 'rest, n num option * 'rest) instr
  | Neg_nat : (n num * 'rest, z num * 'rest) instr
  | Neg_int : (z num * 'rest, z num * 'rest) instr
  | Abs_int : (z num * 'rest, n num * 'rest) instr
  | Int_nat : (n num * 'rest, z num * 'rest) instr
  | Add_intint : (z num * (z num * 'rest), z num * 'rest) instr
  | Add_intnat : (z num * (n num * 'rest), z num * 'rest) instr
  | Add_natint : (n num * (z num * 'rest), z num * 'rest) instr
  | Add_natnat : (n num * (n num * 'rest), n num * 'rest) instr
  | Sub_int : ('s num * ('t num * 'rest), z num * 'rest) instr
  | Mul_intint : (z num * (z num * 'rest), z num * 'rest) instr
  | Mul_intnat : (z num * (n num * 'rest), z num * 'rest) instr
  | Mul_natint : (n num * (z num * 'rest), z num * 'rest) instr
  | Mul_natnat : (n num * (n num * 'rest), n num * 'rest) instr
  | Ediv_intint
      : (z num * (z num * 'rest), (z num, n num) pair option * 'rest) instr
  | Ediv_intnat
      : (z num * (n num * 'rest), (z num, n num) pair option * 'rest) instr
  | Ediv_natint
      : (n num * (z num * 'rest), (z num, n num) pair option * 'rest) instr
  | Ediv_natnat
      : (n num * (n num * 'rest), (n num, n num) pair option * 'rest) instr
  | Lsl_nat : (n num * (n num * 'rest), n num * 'rest) instr
  | Lsr_nat : (n num * (n num * 'rest), n num * 'rest) instr
  | Or_nat : (n num * (n num * 'rest), n num * 'rest) instr
  | And_nat : (n num * (n num * 'rest), n num * 'rest) instr
  | And_int_nat : (z num * (n num * 'rest), n num * 'rest) instr
  | Xor_nat : (n num * (n num * 'rest), n num * 'rest) instr
  | Not_nat : (n num * 'rest, z num * 'rest) instr
  | Not_int : (z num * 'rest, z num * 'rest) instr
  (* control *)
  | Seq : ('bef, 'trans) descr * ('trans, 'aft) descr -> ('bef, 'aft) instr
  | If : ('bef, 'aft) descr * ('bef, 'aft) descr -> (bool * 'bef, 'aft) instr
  | Loop : ('rest, bool * 'rest) descr -> (bool * 'rest, 'rest) instr
  | Loop_left :
      ('a * 'rest, ('a, 'b) union * 'rest) descr
      -> (('a, 'b) union * 'rest, 'b * 'rest) instr
  | Dip : ('bef, 'aft) descr -> ('top * 'bef, 'top * 'aft) instr
  | Exec : ('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr
  | Apply :
      'arg ty
      -> ( 'arg * (('arg * 'remaining, 'ret) lambda * 'rest),
           ('remaining, 'ret) lambda * 'rest )
         instr
  | Lambda : ('arg, 'ret) lambda -> ('rest, ('arg, 'ret) lambda * 'rest) instr
  | Failwith : 'a ty -> ('a * 'rest, 'aft) instr
  | Nop : ('rest, 'rest) instr
  (* comparison *)
  | Compare : 'a comparable_ty -> ('a * ('a * 'rest), z num * 'rest) instr
  (* comparators *)
  | Eq : (z num * 'rest, bool * 'rest) instr
  | Neq : (z num * 'rest, bool * 'rest) instr
  | Lt : (z num * 'rest, bool * 'rest) instr
  | Gt : (z num * 'rest, bool * 'rest) instr
  | Le : (z num * 'rest, bool * 'rest) instr
  | Ge : (z num * 'rest, bool * 'rest) instr
  (* protocol *)
  | Address : (_ typed_contract * 'rest, address * 'rest) instr
  | Contract :
      'p ty * string
      -> (address * 'rest, 'p typed_contract option * 'rest) instr
  | Transfer_tokens
      : ( 'arg * (Tez.t * ('arg typed_contract * 'rest)),
          operation * 'rest )
        instr
  | Create_account
      : ( public_key_hash * (public_key_hash option * (bool * (Tez.t * 'rest))),
          operation * (address * 'rest) )
        instr
  | Implicit_account
      : (public_key_hash * 'rest, unit typed_contract * 'rest) instr
  | Create_contract :
      'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option
      -> ( public_key_hash
           * (public_key_hash option * (bool * (bool * (Tez.t * ('g * 'rest))))),
           operation * (address * 'rest) )
         instr
  | Create_contract_2 :
      'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option
      -> ( public_key_hash option * (Tez.t * ('g * 'rest)),
           operation * (address * 'rest) )
         instr
  | Set_delegate : (public_key_hash option * 'rest, operation * 'rest) instr
  | Now : ('rest, Script_timestamp.t * 'rest) instr
  | Balance : ('rest, Tez.t * 'rest) instr
  | Check_signature
      : (public_key * (signature * (MBytes.t * 'rest)), bool * 'rest) instr
  | Hash_key : (public_key * 'rest, public_key_hash * 'rest) instr
  | Pack : 'a ty -> ('a * 'rest, MBytes.t * 'rest) instr
  | Unpack : 'a ty -> (MBytes.t * 'rest, 'a option * 'rest) instr
  | Blake2b : (MBytes.t * 'rest, MBytes.t * 'rest) instr
  | Sha256 : (MBytes.t * 'rest, MBytes.t * 'rest) instr
  | Sha512 : (MBytes.t * 'rest, MBytes.t * 'rest) instr
  | Steps_to_quota
      : (* TODO: check that it always returns a nat *)
      ('rest, n num * 'rest) instr
  | Source : ('rest, address * 'rest) instr
  | Sender : ('rest, address * 'rest) instr
  | Self : 'p ty * string -> ('rest, 'p typed_contract * 'rest) instr
  | Amount : ('rest, Tez.t * 'rest) instr
  | Dig :
      int * ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness
      -> ('bef, 'x * 'aft) instr
  | Dug :
      int * ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness
      -> ('x * 'bef, 'aft) instr
  | Dipn :
      int
      * ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness
      * ('fbef, 'faft) descr
      -> ('bef, 'aft) instr
  | Dropn :
      int * ('rest, 'rest, 'bef, _) stack_prefix_preservation_witness
      -> ('bef, 'rest) instr
  | ChainId : ('rest, Chain_id.t * 'rest) instr

(* Type witness for operations that work deep in the stack ignoring
   (and preserving) a prefix.

   The two right parameters are the shape of the stack with the (same)
   prefix before and after the transformation. The two left
   parameters are the shape of the stack without the prefix before and
   after. The inductive definition makes it so by construction. *)
and ('bef, 'aft, 'bef_suffix, 'aft_suffix) stack_prefix_preservation_witness =
  | Prefix :
      ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness
      -> ('fbef, 'faft, 'x * 'bef, 'x * 'aft) stack_prefix_preservation_witness
  | Rest : ('bef, 'aft, 'bef, 'aft) stack_prefix_preservation_witness

and ('bef, 'aft) descr = {
  loc : Script.location;
  bef : 'bef stack_ty;
  aft : 'aft stack_ty;
  instr : ('bef, 'aft) instr;
}

type ex_big_map = Ex_bm : ('key, 'value) big_map -> ex_big_map
Script_typed_ir.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.

Import Alpha_context.

Import Script_int.

Inductive var_annot : Set :=
| Var_annot : string -> var_annot.

Inductive type_annot : Set :=
| Type_annot : string -> type_annot.

Inductive field_annot : Set :=
| Field_annot : string -> field_annot.

Inductive annot : Set :=
| Field_annot : string -> annot
| Var_annot : string -> annot
| Type_annot : string -> annot.

Definition address := Alpha_context.Contract.t * string.

Definition pair (a b : Set) := a * b.

Inductive union (a b : Set) : Set :=
| L : a -> union a b
| R : b -> union a b.

Arguments L {_ _}.
Arguments R {_ _}.

Inductive comb : Set :=
| Comb : comb.

Inductive leaf : Set :=
| Leaf : leaf.

Reserved Notation "'comparable_struct".

Inductive comparable_struct_gadt : Set :=
| Int_key : option type_annot -> comparable_struct_gadt
| Nat_key : option type_annot -> comparable_struct_gadt
| String_key : option type_annot -> comparable_struct_gadt
| Bytes_key : option type_annot -> comparable_struct_gadt
| Mutez_key : option type_annot -> comparable_struct_gadt
| Bool_key : option type_annot -> comparable_struct_gadt
| Key_hash_key : option type_annot -> comparable_struct_gadt
| Timestamp_key : option type_annot -> comparable_struct_gadt
| Address_key : option type_annot -> comparable_struct_gadt
| Pair_key :
  comparable_struct_gadt * option field_annot ->
  comparable_struct_gadt * option field_annot -> option type_annot ->
  comparable_struct_gadt

where "'comparable_struct" := (fun (_ _ : Set) => comparable_struct_gadt).

Definition comparable_struct := 'comparable_struct.

Definition comparable_ty (a : Set) := comparable_struct a comb.

Module Boxed_set.
  Record signature {elt OPS_t : Set} := {
    elt := elt;
    elt_ty : comparable_ty elt;
    OPS : S.SET.signature elt OPS_t;
    boxed : OPS.(S.SET.t);
    size : Z;
  }.
  Arguments signature : clear implicits.
End Boxed_set.

Definition set (elt : Set) := {OPS_t : _ & Boxed_set.signature elt OPS_t}.

Module Boxed_map.
  Record signature {key value : Set} {OPS_t : Set -> Set} := {
    key := key;
    value := value;
    key_ty : comparable_ty key;
    OPS : S.MAP.signature key OPS_t;
    boxed : OPS.(S.MAP.t) value * Z;
  }.
  Arguments signature : clear implicits.
End Boxed_map.

Definition map (key value : Set) :=
  {OPS_t : _ & Boxed_map.signature key value OPS_t}.

Definition operation :=
  Alpha_context.packed_internal_operation *
    option Alpha_context.Contract.big_map_diff.

Module descr.
  Record record {loc bef aft instr : Set} := Build {
    loc : loc;
    bef : bef;
    aft : aft;
    instr : instr }.
  Arguments record : clear implicits.
  Definition with_loc {t_loc t_bef t_aft t_instr} loc
    (r : record t_loc t_bef t_aft t_instr) :=
    Build t_loc t_bef t_aft t_instr loc r.(bef) r.(aft) r.(instr).
  Definition with_bef {t_loc t_bef t_aft t_instr} bef
    (r : record t_loc t_bef t_aft t_instr) :=
    Build t_loc t_bef t_aft t_instr r.(loc) bef r.(aft) r.(instr).
  Definition with_aft {t_loc t_bef t_aft t_instr} aft
    (r : record t_loc t_bef t_aft t_instr) :=
    Build t_loc t_bef t_aft t_instr r.(loc) r.(bef) aft r.(instr).
  Definition with_instr {t_loc t_bef t_aft t_instr} instr
    (r : record t_loc t_bef t_aft t_instr) :=
    Build t_loc t_bef t_aft t_instr r.(loc) r.(bef) r.(aft) instr.
End descr.
Definition descr_skeleton := descr.record.

Module big_map.
  Record record {id diff key_type value_type : Set} := Build {
    id : id;
    diff : diff;
    key_type : key_type;
    value_type : value_type }.
  Arguments record : clear implicits.
  Definition with_id {t_id t_diff t_key_type t_value_type} id
    (r : record t_id t_diff t_key_type t_value_type) :=
    Build t_id t_diff t_key_type t_value_type id r.(diff) r.(key_type)
      r.(value_type).
  Definition with_diff {t_id t_diff t_key_type t_value_type} diff
    (r : record t_id t_diff t_key_type t_value_type) :=
    Build t_id t_diff t_key_type t_value_type r.(id) diff r.(key_type)
      r.(value_type).
  Definition with_key_type {t_id t_diff t_key_type t_value_type} key_type
    (r : record t_id t_diff t_key_type t_value_type) :=
    Build t_id t_diff t_key_type t_value_type r.(id) r.(diff) key_type
      r.(value_type).
  Definition with_value_type {t_id t_diff t_key_type t_value_type} value_type
    (r : record t_id t_diff t_key_type t_value_type) :=
    Build t_id t_diff t_key_type t_value_type r.(id) r.(diff) r.(key_type)
      value_type.
End big_map.
Definition big_map_skeleton := big_map.record.

Module script.
  Record record {code arg_type storage storage_type root_name : Set} := Build {
    code : code;
    arg_type : arg_type;
    storage : storage;
    storage_type : storage_type;
    root_name : root_name }.
  Arguments record : clear implicits.
  Definition with_code {t_code t_arg_type t_storage t_storage_type t_root_name}
    code (r : record t_code t_arg_type t_storage t_storage_type t_root_name) :=
    Build t_code t_arg_type t_storage t_storage_type t_root_name code
      r.(arg_type) r.(storage) r.(storage_type) r.(root_name).
  Definition with_arg_type
    {t_code t_arg_type t_storage t_storage_type t_root_name} arg_type
    (r : record t_code t_arg_type t_storage t_storage_type t_root_name) :=
    Build t_code t_arg_type t_storage t_storage_type t_root_name r.(code)
      arg_type r.(storage) r.(storage_type) r.(root_name).
  Definition with_storage
    {t_code t_arg_type t_storage t_storage_type t_root_name} storage
    (r : record t_code t_arg_type t_storage t_storage_type t_root_name) :=
    Build t_code t_arg_type t_storage t_storage_type t_root_name r.(code)
      r.(arg_type) storage r.(storage_type) r.(root_name).
  Definition with_storage_type
    {t_code t_arg_type t_storage t_storage_type t_root_name} storage_type
    (r : record t_code t_arg_type t_storage t_storage_type t_root_name) :=
    Build t_code t_arg_type t_storage t_storage_type t_root_name r.(code)
      r.(arg_type) r.(storage) storage_type r.(root_name).
  Definition with_root_name
    {t_code t_arg_type t_storage t_storage_type t_root_name} root_name
    (r : record t_code t_arg_type t_storage t_storage_type t_root_name) :=
    Build t_code t_arg_type t_storage t_storage_type t_root_name r.(code)
      r.(arg_type) r.(storage) r.(storage_type) root_name.
End script.
Definition script_skeleton := script.record.

Reserved Notation "'script".
Reserved Notation "'end_of_stack".
Reserved Notation "'lambda".
Reserved Notation "'typed_contract".
Reserved Notation "'ty".
Reserved Notation "'stack_ty".
Reserved Notation "'big_map".
Reserved Notation "'instr".
Reserved Notation "'stack_prefix_preservation_witness".
Reserved Notation "'descr".

Inductive lambda_gadt : Set :=
| Lam : forall {arg ret : Set},
  'descr (arg * 'end_of_stack) (ret * 'end_of_stack) ->
  Alpha_context.Script.node -> lambda_gadt

with ty_gadt : Set :=
| Unit_t : option type_annot -> ty_gadt
| Int_t : option type_annot -> ty_gadt
| Nat_t : option type_annot -> ty_gadt
| Signature_t : option type_annot -> ty_gadt
| String_t : option type_annot -> ty_gadt
| Bytes_t : option type_annot -> ty_gadt
| Mutez_t : option type_annot -> ty_gadt
| Key_hash_t : option type_annot -> ty_gadt
| Key_t : option type_annot -> ty_gadt
| Timestamp_t : option type_annot -> ty_gadt
| Address_t : option type_annot -> ty_gadt
| Bool_t : option type_annot -> ty_gadt
| Pair_t :
  ty_gadt * option field_annot * option var_annot ->
  ty_gadt * option field_annot * option var_annot -> option type_annot ->
  bool -> ty_gadt
| Union_t :
  ty_gadt * option field_annot -> ty_gadt * option field_annot ->
  option type_annot -> bool -> ty_gadt
| Lambda_t : ty_gadt -> ty_gadt -> option type_annot -> ty_gadt
| Option_t : ty_gadt -> option type_annot -> bool -> ty_gadt
| List_t : ty_gadt -> option type_annot -> bool -> ty_gadt
| Set_t : forall {v : Set}, comparable_ty v -> option type_annot -> ty_gadt
| Map_t : forall {k : Set},
  comparable_ty k -> ty_gadt -> option type_annot -> bool -> ty_gadt
| Big_map_t : forall {k : Set},
  comparable_ty k -> ty_gadt -> option type_annot -> ty_gadt
| Contract_t : ty_gadt -> option type_annot -> ty_gadt
| Operation_t : option type_annot -> ty_gadt
| Chain_id_t : option type_annot -> ty_gadt

with stack_ty_gadt : Set :=
| Item_t : forall {ty : Set},
  'ty ty -> stack_ty_gadt -> option var_annot -> stack_ty_gadt
| Empty_t : stack_ty_gadt

with instr_gadt : Set :=
| Drop : instr_gadt
| Dup : instr_gadt
| Swap : instr_gadt
| Const : forall {ty : Set}, ty -> instr_gadt
| Cons_pair : instr_gadt
| Car : instr_gadt
| Cdr : instr_gadt
| Cons_some : instr_gadt
| Cons_none : forall {a : Set}, 'ty a -> instr_gadt
| If_none : forall {a aft bef : Set},
  'descr bef aft -> 'descr (a * bef) aft -> instr_gadt
| Left : instr_gadt
| Right : instr_gadt
| If_left : forall {aft bef l r : Set},
  'descr (l * bef) aft -> 'descr (r * bef) aft -> instr_gadt
| Cons_list : instr_gadt
| Nil : instr_gadt
| If_cons : forall {a aft bef : Set},
  'descr (a * (list a * bef)) aft -> 'descr bef aft -> instr_gadt
| List_map : forall {a b rest : Set}, 'descr (a * rest) (b * rest) -> instr_gadt
| List_iter : forall {a rest : Set}, 'descr (a * rest) rest -> instr_gadt
| List_size : instr_gadt
| Empty_set : forall {a : Set}, comparable_ty a -> instr_gadt
| Set_iter : forall {a rest : Set}, 'descr (a * rest) rest -> instr_gadt
| Set_mem : instr_gadt
| Set_update : instr_gadt
| Set_size : instr_gadt
| Empty_map : forall {a v : Set}, comparable_ty a -> 'ty v -> instr_gadt
| Map_map : forall {a r rest v : Set},
  'descr ((a * v) * rest) (r * rest) -> instr_gadt
| Map_iter : forall {a rest v : Set}, 'descr ((a * v) * rest) rest -> instr_gadt
| Map_mem : instr_gadt
| Map_get : instr_gadt
| Map_update : instr_gadt
| Map_size : instr_gadt
| Empty_big_map : forall {a v : Set}, comparable_ty a -> 'ty v -> instr_gadt
| Big_map_mem : instr_gadt
| Big_map_get : instr_gadt
| Big_map_update : instr_gadt
| Concat_string : instr_gadt
| Concat_string_pair : instr_gadt
| Slice_string : instr_gadt
| String_size : instr_gadt
| Concat_bytes : instr_gadt
| Concat_bytes_pair : instr_gadt
| Slice_bytes : instr_gadt
| Bytes_size : instr_gadt
| Add_seconds_to_timestamp : instr_gadt
| Add_timestamp_to_seconds : instr_gadt
| Sub_timestamp_seconds : instr_gadt
| Diff_timestamps : instr_gadt
| Add_tez : instr_gadt
| Sub_tez : instr_gadt
| Mul_teznat : instr_gadt
| Mul_nattez : instr_gadt
| Ediv_teznat : instr_gadt
| Ediv_tez : instr_gadt
| Or : instr_gadt
| And : instr_gadt
| Xor : instr_gadt
| Not : instr_gadt
| Is_nat : instr_gadt
| Neg_nat : instr_gadt
| Neg_int : instr_gadt
| Abs_int : instr_gadt
| Int_nat : instr_gadt
| Add_intint : instr_gadt
| Add_intnat : instr_gadt
| Add_natint : instr_gadt
| Add_natnat : instr_gadt
| Sub_int : instr_gadt
| Mul_intint : instr_gadt
| Mul_intnat : instr_gadt
| Mul_natint : instr_gadt
| Mul_natnat : instr_gadt
| Ediv_intint : instr_gadt
| Ediv_intnat : instr_gadt
| Ediv_natint : instr_gadt
| Ediv_natnat : instr_gadt
| Lsl_nat : instr_gadt
| Lsr_nat : instr_gadt
| Or_nat : instr_gadt
| And_nat : instr_gadt
| And_int_nat : instr_gadt
| Xor_nat : instr_gadt
| Not_nat : instr_gadt
| Not_int : instr_gadt
| Seq : forall {aft bef trans : Set},
  'descr bef trans -> 'descr trans aft -> instr_gadt
| If : forall {aft bef : Set}, 'descr bef aft -> 'descr bef aft -> instr_gadt
| Loop : forall {rest : Set}, 'descr rest (bool * rest) -> instr_gadt
| Loop_left : forall {a b rest : Set},
  'descr (a * rest) (union a b * rest) -> instr_gadt
| Dip : forall {aft bef : Set}, 'descr bef aft -> instr_gadt
| Exec : instr_gadt
| Apply : forall {arg : Set}, 'ty arg -> instr_gadt
| Lambda : forall {arg ret : Set}, 'lambda arg ret -> instr_gadt
| Failwith : forall {a : Set}, 'ty a -> instr_gadt
| Nop : instr_gadt
| Compare : forall {a : Set}, comparable_ty a -> instr_gadt
| Eq : instr_gadt
| Neq : instr_gadt
| Lt : instr_gadt
| Gt : instr_gadt
| Le : instr_gadt
| Ge : instr_gadt
| Address : instr_gadt
| Contract : forall {p : Set}, 'ty p -> string -> instr_gadt
| Transfer_tokens : instr_gadt
| Create_account : instr_gadt
| Implicit_account : instr_gadt
| Create_contract : forall {g p : Set},
  'ty g -> 'ty p -> 'lambda (p * g) (list operation * g) -> option string ->
  instr_gadt
| Create_contract_2 : forall {g p : Set},
  'ty g -> 'ty p -> 'lambda (p * g) (list operation * g) -> option string ->
  instr_gadt
| Set_delegate : instr_gadt
| Now : instr_gadt
| Balance : instr_gadt
| Check_signature : instr_gadt
| Hash_key : instr_gadt
| Pack : forall {a : Set}, 'ty a -> instr_gadt
| Unpack : forall {a : Set}, 'ty a -> instr_gadt
| Blake2b : instr_gadt
| Sha256 : instr_gadt
| Sha512 : instr_gadt
| Steps_to_quota : instr_gadt
| Source : instr_gadt
| Sender : instr_gadt
| Self : forall {p : Set}, 'ty p -> string -> instr_gadt
| Amount : instr_gadt
| Dig : forall {aft bef rest x : Set},
  Z -> 'stack_prefix_preservation_witness (x * rest) rest bef aft -> instr_gadt
| Dug : forall {aft bef rest x : Set},
  Z -> 'stack_prefix_preservation_witness rest (x * rest) bef aft -> instr_gadt
| Dipn : forall {aft bef faft fbef : Set},
  Z -> 'stack_prefix_preservation_witness fbef faft bef aft ->
  'descr fbef faft -> instr_gadt
| Dropn : forall {C bef rest : Set},
  Z -> 'stack_prefix_preservation_witness rest rest bef C -> instr_gadt
| ChainId : instr_gadt

with stack_prefix_preservation_witness_gadt : Set :=
| Prefix :
  stack_prefix_preservation_witness_gadt ->
  stack_prefix_preservation_witness_gadt
| Rest : stack_prefix_preservation_witness_gadt

where "'script" := (fun (t_arg t_storage : Set) =>
  script_skeleton
    ('lambda (pair t_arg t_storage) (pair (list operation) t_storage))
    ('ty t_arg) t_storage ('ty t_storage) (option string))
and "'end_of_stack" := (unit)
and "'lambda" := (fun (_ _ : Set) => lambda_gadt)
and "'typed_contract" := (fun (t_arg : Set) => 'ty t_arg * address)
and "'ty" := (fun (_ : Set) => ty_gadt)
and "'stack_ty" := (fun (_ : Set) => stack_ty_gadt)
and "'big_map" := (fun (t_key t_value : Set) =>
  big_map_skeleton (option Z.t) (map t_key (option t_value)) ('ty t_key)
    ('ty t_value))
and "'instr" := (fun (_ _ : Set) => instr_gadt)
and "'stack_prefix_preservation_witness" := (fun (_ _ _ _ : Set) =>
  stack_prefix_preservation_witness_gadt)
and "'descr" := (fun (t_bef t_aft : Set) =>
  descr_skeleton Alpha_context.Script.location ('stack_ty t_bef)
    ('stack_ty t_aft) ('instr t_bef t_aft)).

Definition script := 'script.
Definition end_of_stack := 'end_of_stack.
Definition lambda := 'lambda.
Definition typed_contract := 'typed_contract.
Definition ty := 'ty.
Definition stack_ty := 'stack_ty.
Definition big_map := 'big_map.
Definition instr := 'instr.
Definition stack_prefix_preservation_witness :=
  'stack_prefix_preservation_witness.
Definition descr := 'descr.

Reserved Notation "'ex_big_map".

Inductive ex_big_map_gadt : Set :=
| Ex_bm : forall {key value : Set}, big_map key value -> ex_big_map_gadt

where "'ex_big_map" := (ex_big_map_gadt).

Definition ex_big_map := 'ex_big_map.

Seed_repr

  • OCaml size: 134 lines
  • Coq size: 146 lines (+8% compared to OCaml)
seed_repr.ml 4 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Random number generation *)

type seed = B of State_hash.t

type t = T of State_hash.t

type sequence = S of State_hash.t

type nonce = MBytes.t

let nonce_encoding = Data_encoding.Fixed.bytes Constants_repr.nonce_length

let init = "Laissez-faire les proprietaires."

let zero_bytes = MBytes.of_string (String.make Nonce_hash.size '\000')

let state_hash_encoding =
  let open Data_encoding in
  conv
    State_hash.to_bytes
    State_hash.of_bytes_exn
    (Fixed.bytes Nonce_hash.size)

let seed_encoding =
  let open Data_encoding in
  conv (fun (B b) -> b) (fun b -> B b) state_hash_encoding

let empty = B (State_hash.hash_bytes [MBytes.of_string init])

let nonce (B state) nonce =
  B (State_hash.hash_bytes [State_hash.to_bytes state; nonce])

let initialize_new (B state) append =
  T (State_hash.hash_bytes (State_hash.to_bytes state :: zero_bytes :: append))

let xor_higher_bits i b =
  let higher = MBytes.get_int32 b 0 in
  let r = Int32.logxor higher i in
  let res = MBytes.copy b in
  MBytes.set_int32 res 0 r ; res

let sequence (T state) n =
  State_hash.to_bytes state |> xor_higher_bits n
  |> fun b -> S (State_hash.hash_bytes [b])

let take (S state) =
  let b = State_hash.to_bytes state in
  let h = State_hash.hash_bytes [b] in
  (State_hash.to_bytes h, S h)

let take_int32 s bound =
  if Compare.Int32.(bound <= 0l) then invalid_arg "Seed_repr.take_int32"
    (* FIXME *)
  else
    let rec loop s =
      let (bytes, s) = take s in
      let r = Int32.abs (MBytes.get_int32 bytes 0) in
      let drop_if_over =
        Int32.sub Int32.max_int (Int32.rem Int32.max_int bound)
      in
      if Compare.Int32.(r >= drop_if_over) then loop s
      else
        let v = Int32.rem r bound in
        (v, s)
    in
    loop s

type error += Unexpected_nonce_length (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"unexpected_nonce_length"
    ~title:"Unexpected nonce length"
    ~description:"Nonce length is incorrect."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "Nonce length is not %i bytes long as it should."
        Constants_repr.nonce_length)
    Data_encoding.empty
    (function Unexpected_nonce_length -> Some () | _ -> None)
    (fun () -> Unexpected_nonce_length)

let make_nonce nonce =
  if Compare.Int.(MBytes.length nonce <> Constants_repr.nonce_length) then
    error Unexpected_nonce_length
  else ok nonce

let hash nonce = Nonce_hash.hash_bytes [nonce]

let check_hash nonce hash =
  Compare.Int.(MBytes.length nonce = Constants_repr.nonce_length)
  && Nonce_hash.equal (Nonce_hash.hash_bytes [nonce]) hash

let nonce_hash_key_part = Nonce_hash.to_path

let initial_nonce_0 = zero_bytes

let initial_nonce_hash_0 = hash initial_nonce_0

let deterministic_seed seed = nonce seed zero_bytes

let initial_seeds n =
  let rec loop acc elt i =
    if Compare.Int.(i = 1) then List.rev (elt :: acc)
    else loop (elt :: acc) (deterministic_seed elt) (i - 1)
  in
  loop [] (B (State_hash.hash_bytes [])) n
Seed_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Constants_repr.
Require Tezos.Nonce_hash.
Require Tezos.State_hash.

Inductive seed : Set :=
| B : State_hash.t -> seed.

Inductive t : Set :=
| T : State_hash.t -> t.

Inductive sequence : Set :=
| S : State_hash.t -> sequence.

Definition nonce := MBytes.t.

Definition nonce_encoding : Data_encoding.encoding MBytes.t :=
  Data_encoding.Fixed.__bytes_value Constants_repr.nonce_length.

Definition init : string := "Laissez-faire les proprietaires.".

Definition zero_bytes : MBytes.t :=
  MBytes.of_string (String.make Nonce_hash.size "000" % char).

Definition state_hash_encoding : Data_encoding.encoding State_hash.t :=
  Data_encoding.conv State_hash.to_bytes State_hash.of_bytes_exn None
    (Data_encoding.Fixed.__bytes_value Nonce_hash.size).

Definition seed_encoding : Data_encoding.encoding seed :=
  Data_encoding.conv
    (fun function_parameter =>
      let 'B b := function_parameter in
      b) (fun b => B b) None state_hash_encoding.

Definition empty : seed :=
  B (State_hash.hash_bytes None [ MBytes.of_string init ]).

Definition __nonce_value (function_parameter : seed) : MBytes.t -> seed :=
  let 'B state := function_parameter in
  fun __nonce_value =>
    B (State_hash.hash_bytes None [ State_hash.to_bytes state; __nonce_value ]).

Definition initialize_new (function_parameter : seed) : list MBytes.t -> t :=
  let 'B state := function_parameter in
  fun append =>
    T
      (State_hash.hash_bytes None
        (cons (State_hash.to_bytes state) (cons zero_bytes append))).

Definition xor_higher_bits (i : int32) (b : MBytes.t) : MBytes.t :=
  let higher := MBytes.get_int32 b 0 in
  let r := Int32.logxor higher i in
  let res := MBytes.copy b in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  res.

Definition __sequence_value (function_parameter : t) : int32 -> sequence :=
  let 'T state := function_parameter in
  fun n =>
    Pervasives.op_pipegt
      (Pervasives.op_pipegt (State_hash.to_bytes state) (xor_higher_bits n))
      (fun b => S (State_hash.hash_bytes None [ b ])).

Definition take (function_parameter : sequence) : MBytes.t * sequence :=
  let 'S state := function_parameter in
  let b := State_hash.to_bytes state in
  let h := State_hash.hash_bytes None [ b ] in
  ((State_hash.to_bytes h), (S h)).

Definition take_int32 (s : sequence) (bound : (|Compare.Int32|).(Compare.S.t))
  : int32 * sequence :=
  if
    (|Compare.Int32|).(Compare.S.op_lteq) bound
      (* ❌ Constant of type int32 is converted to int *)
      0 then
    Pervasives.invalid_arg "Seed_repr.take_int32"
  else
    let fix loop (s : sequence) {struct s} : int32 * sequence :=
      let '(__bytes_value, s) := take s in
      let r := Int32.abs (MBytes.get_int32 __bytes_value 0) in
      let drop_if_over :=
        Int32.sub Int32.max_int (Int32.rem Int32.max_int bound) in
      if (|Compare.Int32|).(Compare.S.op_gteq) r drop_if_over then
        loop s
      else
        let v := Int32.rem r bound in
        (v, s) in
    loop s.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition make_nonce (__nonce_value : MBytes.t)
  : Error_monad.tzresult MBytes.t :=
  if
    (|Compare.Int|).(Compare.S.op_ltgt) (MBytes.length __nonce_value)
      Constants_repr.nonce_length then
    Error_monad.__error_value extensible_type_value
  else
    Error_monad.ok __nonce_value.

Definition __hash_value (__nonce_value : MBytes.t) : Nonce_hash.t :=
  Nonce_hash.hash_bytes None [ __nonce_value ].

Definition check_hash (__nonce_value : MBytes.t) (__hash_value : Nonce_hash.t)
  : bool :=
  Pervasives.op_andand
    ((|Compare.Int|).(Compare.S.op_eq) (MBytes.length __nonce_value)
      Constants_repr.nonce_length)
    (Nonce_hash.equal (Nonce_hash.hash_bytes None [ __nonce_value ])
      __hash_value).

Definition nonce_hash_key_part : Nonce_hash.t -> list string -> list string :=
  Nonce_hash.to_path.

Definition initial_nonce_0 : MBytes.t := zero_bytes.

Definition initial_nonce_hash_0 : Nonce_hash.t := __hash_value initial_nonce_0.

Definition deterministic_seed (__seed_value : seed) : seed :=
  __nonce_value __seed_value zero_bytes.

Definition initial_seeds (n : (|Compare.Int|).(Compare.S.t)) : list seed :=
  let fix loop
    (acc : list seed) (elt : seed) (i : (|Compare.Int|).(Compare.S.t))
    {struct acc} : list seed :=
    if (|Compare.Int|).(Compare.S.op_eq) i 1 then
      List.rev (cons elt acc)
    else
      loop (cons elt acc) (deterministic_seed elt) (Pervasives.op_minus i 1) in
  loop [] (B (State_hash.hash_bytes None [])) n.

Seed_repr_mli

  • OCaml size: 100 lines
  • Coq size: 53 lines (-47% compared to OCaml)
seed_repr.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Implementation - Random number generation

    This is not expected to be a good cryptographic random number
    generator. In particular this is supposed to be used in situations
    where the seed is a globaly known information.

    The only expected property is: It should be difficult to find a
    seed such that the generated sequence is a given one. *)

(** {2 Random Generation} *)

(** The state of the random number generator *)
type t

(** A random seed, to derive random sequences from *)
type seed

(** A random sequence, to derive random values from *)
type sequence

(** [initialize_new state ident] returns a new generator *)
val initialize_new : seed -> MBytes.t list -> t

(** [sequence state n] prepares the n-th sequence of a state  *)
val sequence : t -> int32 -> sequence

(** Generates the next random value in the sequence *)
val take : sequence -> MBytes.t * sequence

(** Generates the next random value as a bounded [int32] *)
val take_int32 : sequence -> int32 -> int32 * sequence

(** {2 Predefined seeds} *)

val empty : seed

(** Returns a new seed by hashing the one passed with a constant. *)
val deterministic_seed : seed -> seed

(** [intial_seeds n] generates the first [n] seeds for which there are no nonces.
    The first seed is a constant value. The kth seed is the hash of seed (k-1)
    concatenated with a constant. *)
val initial_seeds : int -> seed list

(** {2 Entropy} *)

(** A nonce for adding entropy to the generator *)
type nonce

(** Add entropy to the seed generator *)
val nonce : seed -> nonce -> seed

(** Use a byte sequence as a nonce *)
val make_nonce : MBytes.t -> nonce tzresult

(** Compute the has of a nonce *)
val hash : nonce -> Nonce_hash.t

(** [check_hash nonce hash] is true if the nonce correspond to the hash *)
val check_hash : nonce -> Nonce_hash.t -> bool

(** For using nonce hashes as keys in the hierarchical database *)
val nonce_hash_key_part : Nonce_hash.t -> string list -> string list

(** {2 Predefined nonce} *)

val initial_nonce_0 : nonce

val initial_nonce_hash_0 : Nonce_hash.t

(** {2 Serializers} *)

val nonce_encoding : nonce Data_encoding.t

val seed_encoding : seed Data_encoding.t
Seed_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Nonce_hash.

Parameter t : Set.

Parameter seed : Set.

Parameter sequence : Set.

Parameter initialize_new : seed -> list MBytes.t -> t.

Parameter __sequence_value : t -> int32 -> sequence.

Parameter take : sequence -> MBytes.t * sequence.

Parameter take_int32 : sequence -> int32 -> int32 * sequence.

Parameter empty : seed.

Parameter deterministic_seed : seed -> seed.

Parameter initial_seeds : Z -> list seed.

Parameter nonce : Set.

Parameter __nonce_value : seed -> nonce -> seed.

Parameter make_nonce : MBytes.t -> Error_monad.tzresult nonce.

Parameter __hash_value : nonce -> Nonce_hash.t.

Parameter check_hash : nonce -> Nonce_hash.t -> bool.

Parameter nonce_hash_key_part : Nonce_hash.t -> list string -> list string.

Parameter initial_nonce_0 : nonce.

Parameter initial_nonce_hash_0 : Nonce_hash.t.

Parameter nonce_encoding : Data_encoding.t nonce.

Parameter seed_encoding : Data_encoding.t seed.

Seed_storage

  • OCaml size: 148 lines
  • Coq size: 136 lines (-9% compared to OCaml)
seed_storage.ml 4 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Misc

type error +=
  | Unknown of {
      oldest : Cycle_repr.t;
      cycle : Cycle_repr.t;
      latest : Cycle_repr.t;
    }

(* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"seed.unknown_seed"
    ~title:"Unknown seed"
    ~description:"The requested seed is not available"
    ~pp:(fun ppf (oldest, cycle, latest) ->
      if Cycle_repr.(cycle < oldest) then
        Format.fprintf
          ppf
          "The seed for cycle %a has been cleared from the context  (oldest \
           known seed is for cycle %a)"
          Cycle_repr.pp
          cycle
          Cycle_repr.pp
          oldest
      else
        Format.fprintf
          ppf
          "The seed for cycle %a has not been computed yet  (latest known \
           seed is for cycle %a)"
          Cycle_repr.pp
          cycle
          Cycle_repr.pp
          latest)
    Data_encoding.(
      obj3
        (req "oldest" Cycle_repr.encoding)
        (req "requested" Cycle_repr.encoding)
        (req "latest" Cycle_repr.encoding))
    (function
      | Unknown {oldest; cycle; latest} ->
          Some (oldest, cycle, latest)
      | _ ->
          None)
    (fun (oldest, cycle, latest) -> Unknown {oldest; cycle; latest})

let compute_for_cycle c ~revealed cycle =
  match Cycle_repr.pred cycle with
  | None ->
      assert false (* should not happen *)
  | Some previous_cycle ->
      let levels = Level_storage.levels_with_commitments_in_cycle c revealed in
      let combine (c, random_seed, unrevealed) level =
        Storage.Seed.Nonce.get c level
        >>=? function
        | Revealed nonce ->
            Storage.Seed.Nonce.delete c level
            >>=? fun c ->
            return (c, Seed_repr.nonce random_seed nonce, unrevealed)
        | Unrevealed u ->
            Storage.Seed.Nonce.delete c level
            >>=? fun c -> return (c, random_seed, u :: unrevealed)
      in
      Storage.Seed.For_cycle.get c previous_cycle
      >>=? fun prev_seed ->
      let seed = Seed_repr.deterministic_seed prev_seed in
      fold_left_s combine (c, seed, []) levels
      >>=? fun (c, seed, unrevealed) ->
      Storage.Seed.For_cycle.init c cycle seed
      >>=? fun c -> return (c, unrevealed)

let for_cycle ctxt cycle =
  let preserved = Constants_storage.preserved_cycles ctxt in
  let current_level = Level_storage.current ctxt in
  let current_cycle = current_level.cycle in
  let latest =
    if Cycle_repr.(current_cycle = root) then
      Cycle_repr.add current_cycle (preserved + 1)
    else Cycle_repr.add current_cycle preserved
  in
  let oldest =
    match Cycle_repr.sub current_cycle preserved with
    | None ->
        Cycle_repr.root
    | Some oldest ->
        oldest
  in
  fail_unless
    Cycle_repr.(oldest <= cycle && cycle <= latest)
    (Unknown {oldest; cycle; latest})
  >>=? fun () -> Storage.Seed.For_cycle.get ctxt cycle

let clear_cycle c cycle = Storage.Seed.For_cycle.delete c cycle

let init ctxt =
  let preserved = Constants_storage.preserved_cycles ctxt in
  List.fold_left2
    (fun ctxt c seed ->
      ctxt
      >>=? fun ctxt ->
      let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in
      Storage.Seed.For_cycle.init ctxt cycle seed)
    (return ctxt)
    (0 --> (preserved + 1))
    (Seed_repr.initial_seeds (preserved + 2))

let cycle_end ctxt last_cycle =
  let preserved = Constants_storage.preserved_cycles ctxt in
  ( match Cycle_repr.sub last_cycle preserved with
  | None ->
      return ctxt
  | Some cleared_cycle ->
      clear_cycle ctxt cleared_cycle )
  >>=? fun ctxt ->
  match Cycle_repr.pred last_cycle with
  | None ->
      return (ctxt, [])
  | Some revealed ->
      (* cycle with revelations *)
      let inited_seed_cycle = Cycle_repr.add last_cycle (preserved + 1) in
      compute_for_cycle ctxt ~revealed inited_seed_cycle
Seed_storage.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Constants_storage.
Require Tezos.Cycle_repr.
Require Tezos.Level_repr.
Require Tezos.Level_storage.
Require Tezos.Misc.
Require Tezos.Raw_context.
Require Tezos.Seed_repr.
Require Tezos.Storage.

Import Misc.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition compute_for_cycle
  (c : Raw_context.t) (revealed : Cycle_repr.t) (cycle : Cycle_repr.cycle)
  : Lwt.t
    (Error_monad.tzresult (Raw_context.t * list Storage.Seed.unrevealed_nonce)) :=
  match Cycle_repr.pred cycle with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some previous_cycle =>
    let levels := Level_storage.levels_with_commitments_in_cycle c revealed in
    let combine
      (function_parameter :
        Storage.Seed.Nonce.context * Seed_repr.seed *
          list Storage.Seed.unrevealed_nonce)
      : Level_repr.t ->
      Lwt.t
        (Error_monad.tzresult
          (Raw_context.t * Seed_repr.seed * list Storage.Seed.unrevealed_nonce)) :=
      let '(c, random_seed, unrevealed) := function_parameter in
      fun level =>
        Error_monad.op_gtgteqquestion (Storage.Seed.Nonce.get c level)
          (fun function_parameter =>
            match function_parameter with
            | Storage.Seed.Revealed __nonce_value =>
              Error_monad.op_gtgteqquestion (Storage.Seed.Nonce.delete c level)
                (fun c =>
                  Error_monad.__return
                    (c, (Seed_repr.__nonce_value random_seed __nonce_value),
                      unrevealed))
            | Storage.Seed.Unrevealed u =>
              Error_monad.op_gtgteqquestion (Storage.Seed.Nonce.delete c level)
                (fun c =>
                  Error_monad.__return (c, random_seed, (cons u unrevealed)))
            end) in
    Error_monad.op_gtgteqquestion (Storage.Seed.For_cycle.get c previous_cycle)
      (fun prev_seed =>
        let __seed_value := Seed_repr.deterministic_seed prev_seed in
        Error_monad.op_gtgteqquestion
          (Error_monad.fold_left_s combine (c, __seed_value, []) levels)
          (fun function_parameter =>
            let '(c, __seed_value, unrevealed) := function_parameter in
            Error_monad.op_gtgteqquestion
              (Storage.Seed.For_cycle.init c cycle __seed_value)
              (fun c => Error_monad.__return (c, unrevealed))))
  end.

Definition for_cycle (ctxt : Raw_context.context) (cycle : Cycle_repr.t)
  : Lwt.t (Error_monad.tzresult Seed_repr.seed) :=
  let preserved := Constants_storage.preserved_cycles ctxt in
  let current_level := Level_storage.current ctxt in
  let current_cycle := Level_repr.t.cycle current_level in
  let latest :=
    if Cycle_repr.op_eq current_cycle Cycle_repr.root then
      Cycle_repr.add current_cycle (Pervasives.op_plus preserved 1)
    else
      Cycle_repr.add current_cycle preserved in
  let oldest :=
    match Cycle_repr.sub current_cycle preserved with
    | None => Cycle_repr.root
    | Some oldest => oldest
    end in
  Error_monad.op_gtgteqquestion
    (Error_monad.fail_unless
      (Pervasives.op_andand (Cycle_repr.op_lteq oldest cycle)
        (Cycle_repr.op_lteq cycle latest)) extensible_type_value)
    (fun function_parameter =>
      let '_ := function_parameter in
      Storage.Seed.For_cycle.get ctxt cycle).

Definition clear_cycle (c : Raw_context.t) (cycle : Cycle_repr.t)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Storage.Seed.For_cycle.delete c cycle.

Definition init (ctxt : Raw_context.context)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let preserved := Constants_storage.preserved_cycles ctxt in
  List.fold_left2
    (fun ctxt =>
      fun c =>
        fun __seed_value =>
          Error_monad.op_gtgteqquestion ctxt
            (fun ctxt =>
              let cycle := Cycle_repr.of_int32_exn (Int32.of_int c) in
              Storage.Seed.For_cycle.init ctxt cycle __seed_value))
    (Error_monad.__return ctxt)
    (Misc.op_minusminusgt 0 (Pervasives.op_plus preserved 1))
    (Seed_repr.initial_seeds (Pervasives.op_plus preserved 2)).

Definition cycle_end
  (ctxt : Raw_context.context) (last_cycle : Cycle_repr.cycle)
  : Lwt.t
    (Error_monad.tzresult
      (Raw_context.context * list Storage.Seed.unrevealed_nonce)) :=
  let preserved := Constants_storage.preserved_cycles ctxt in
  Error_monad.op_gtgteqquestion
    match Cycle_repr.sub last_cycle preserved with
    | None => Error_monad.__return ctxt
    | Some cleared_cycle => clear_cycle ctxt cleared_cycle
    end
    (fun ctxt =>
      match Cycle_repr.pred last_cycle with
      | None => Error_monad.__return (ctxt, [])
      | Some revealed =>
        let inited_seed_cycle :=
          Cycle_repr.add last_cycle (Pervasives.op_plus preserved 1) in
        compute_for_cycle ctxt revealed inited_seed_cycle
      end).

Seed_storage_mli

  • OCaml size: 47 lines
  • Coq size: 27 lines (-43% compared to OCaml)
seed_storage.mli 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error +=
  | Unknown of {
      oldest : Cycle_repr.t;
      cycle : Cycle_repr.t;
      latest : Cycle_repr.t;
    }

(* `Permanent *)

(** Generates the first [preserved_cycles+2] seeds for which
    there are no nonces. *)
val init : Raw_context.t -> Raw_context.t tzresult Lwt.t

val for_cycle : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t

(** If it is the end of the cycle, computes and stores the seed of cycle at
    distance [preserved_cycle+2] in the future using the seed of the previous
    cycle and the revelations of the current one.  *)
val cycle_end :
  Raw_context.t ->
  Cycle_repr.t ->
  (Raw_context.t * Nonce_storage.unrevealed list) tzresult Lwt.t
Seed_storage_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Cycle_repr.
Require Tezos.Nonce_storage.
Require Tezos.Raw_context.
Require Tezos.Seed_repr.

(* extensible_type error *)

Parameter init : Raw_context.t -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter for_cycle :
  Raw_context.t -> Cycle_repr.t -> Lwt.t (Error_monad.tzresult Seed_repr.seed).

Parameter cycle_end :
  Raw_context.t -> Cycle_repr.t ->
  Lwt.t (Error_monad.tzresult (Raw_context.t * list Nonce_storage.unrevealed)).

Services_registration

  • OCaml size: 94 lines
  • Coq size: 202 lines (+114% compared to OCaml)
services_registration.ml 10 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

type rpc_context = {
  block_hash : Block_hash.t;
  block_header : Block_header.shell_header;
  context : Alpha_context.t;
}

let rpc_init ({block_hash; block_header; context} : Updater.rpc_context) =
  let level = block_header.level in
  let timestamp = block_header.timestamp in
  let fitness = block_header.fitness in
  Alpha_context.prepare
    ~level
    ~predecessor_timestamp:timestamp
    ~timestamp
    ~fitness
    context
  >>=? fun context -> return {block_hash; block_header; context}

let rpc_services =
  ref (RPC_directory.empty : Updater.rpc_context RPC_directory.t)

let register0_fullctxt s f =
  rpc_services :=
    RPC_directory.register !rpc_services s (fun ctxt q i ->
        rpc_init ctxt >>=? fun ctxt -> f ctxt q i)

let opt_register0_fullctxt s f =
  rpc_services :=
    RPC_directory.opt_register !rpc_services s (fun ctxt q i ->
        rpc_init ctxt >>=? fun ctxt -> f ctxt q i)

let register0 s f = register0_fullctxt s (fun {context; _} -> f context)

let register0_noctxt s f =
  rpc_services := RPC_directory.register !rpc_services s (fun _ q i -> f q i)

let register1_fullctxt s f =
  rpc_services :=
    RPC_directory.register !rpc_services s (fun (ctxt, arg) q i ->
        rpc_init ctxt >>=? fun ctxt -> f ctxt arg q i)

let register1 s f = register1_fullctxt s (fun {context; _} x -> f context x)

let register1_noctxt s f =
  rpc_services :=
    RPC_directory.register !rpc_services s (fun (_, arg) q i -> f arg q i)

let register2_fullctxt s f =
  rpc_services :=
    RPC_directory.register !rpc_services s (fun ((ctxt, arg1), arg2) q i ->
        rpc_init ctxt >>=? fun ctxt -> f ctxt arg1 arg2 q i)

let register2 s f =
  register2_fullctxt s (fun {context; _} a1 a2 q i -> f context a1 a2 q i)

let get_rpc_services () =
  let p =
    RPC_directory.map
      (fun c ->
        rpc_init c
        >>= function Error _ -> assert false | Ok c -> Lwt.return c.context)
      (Storage_description.build_directory Alpha_context.description)
  in
  RPC_directory.register_dynamic_directory
    !rpc_services
    RPC_path.(open_root / "context" / "raw" / "json")
    (fun _ -> Lwt.return p)
Services_registration.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Storage_description.

Import Alpha_context.

Module rpc_context.
  Record record := Build {
    block_hash : (|Block_hash|).(S.HASH.t);
    block_header : Alpha_context.Block_header.shell_header;
    context : Alpha_context.t }.
  Definition with_block_hash block_hash (r : record) :=
    Build block_hash r.(block_header) r.(context).
  Definition with_block_header block_header (r : record) :=
    Build r.(block_hash) block_header r.(context).
  Definition with_context context (r : record) :=
    Build r.(block_hash) r.(block_header) context.
End rpc_context.
Definition rpc_context := rpc_context.record.

Definition rpc_init (function_parameter : Updater.rpc_context)
  : Lwt.t (Error_monad.tzresult rpc_context) :=
  let '{|
    Updater.rpc_context.block_hash := block_hash;
      Updater.rpc_context.block_header := block_header;
      Updater.rpc_context.context := context
      |} := function_parameter in
  let level := Block_header.shell_header.level block_header in
  let timestamp := Block_header.shell_header.timestamp block_header in
  let fitness := Block_header.shell_header.fitness block_header in
  Error_monad.op_gtgteqquestion
    (Alpha_context.prepare context level timestamp timestamp fitness)
    (fun context =>
      Error_monad.__return
        {| rpc_context.block_hash := block_hash;
          rpc_context.block_header := block_header;
          rpc_context.context := context |}).

Definition rpc_services
  : Pervasives.ref (RPC_directory.t Updater.rpc_context) :=
  Pervasives.__ref_value RPC_directory.empty.

Definition register0_fullctxt {A B C : Set}
  (s :
    RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) Updater.rpc_context
      Updater.rpc_context A B C)
  (f : rpc_context -> A -> B -> Lwt.t (Error_monad.tzresult C)) : unit :=
  Pervasives.op_coloneq rpc_services
    (RPC_directory.register (Pervasives.op_exclamation rpc_services) s
      (fun ctxt =>
        fun q =>
          fun i =>
            Error_monad.op_gtgteqquestion (rpc_init ctxt)
              (fun ctxt => f ctxt q i))).

Definition opt_register0_fullctxt {A B C : Set}
  (s :
    RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) Updater.rpc_context
      Updater.rpc_context A B C)
  (f : rpc_context -> A -> B -> Lwt.t (Error_monad.tzresult (option C)))
  : unit :=
  Pervasives.op_coloneq rpc_services
    (RPC_directory.opt_register (Pervasives.op_exclamation rpc_services) s
      (fun ctxt =>
        fun q =>
          fun i =>
            Error_monad.op_gtgteqquestion (rpc_init ctxt)
              (fun ctxt => f ctxt q i))).

Definition register0 {A B C : Set}
  (s :
    RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) Updater.rpc_context
      Updater.rpc_context A B C)
  (f : Alpha_context.t -> A -> B -> Lwt.t (Error_monad.tzresult C)) : unit :=
  register0_fullctxt s
    (fun function_parameter =>
      let '{| rpc_context.context := context |} := function_parameter in
      f context).

Definition register0_noctxt {A B C D : Set}
  (s :
    RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) Updater.rpc_context A B C D)
  (f : B -> C -> Lwt.t (Error_monad.tzresult D)) : unit :=
  Pervasives.op_coloneq rpc_services
    (RPC_directory.register (Pervasives.op_exclamation rpc_services) s
      (fun function_parameter =>
        let '_ := function_parameter in
        fun q => fun i => f q i)).

Definition register1_fullctxt {A B C D : Set}
  (s :
    RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) Updater.rpc_context
      (Updater.rpc_context * A) B C D)
  (f : rpc_context -> A -> B -> C -> Lwt.t (Error_monad.tzresult D)) : unit :=
  Pervasives.op_coloneq rpc_services
    (RPC_directory.register (Pervasives.op_exclamation rpc_services) s
      (fun function_parameter =>
        let '(ctxt, arg) := function_parameter in
        fun q =>
          fun i =>
            Error_monad.op_gtgteqquestion (rpc_init ctxt)
              (fun ctxt => f ctxt arg q i))).

Definition register1 {A B C D : Set}
  (s :
    RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) Updater.rpc_context
      (Updater.rpc_context * A) B C D)
  (f : Alpha_context.t -> A -> B -> C -> Lwt.t (Error_monad.tzresult D))
  : unit :=
  register1_fullctxt s
    (fun function_parameter =>
      let '{| rpc_context.context := context |} := function_parameter in
      fun x => f context x).

Definition register1_noctxt {A B C D E : Set}
  (s :
    RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) Updater.rpc_context (A * B) C D E)
  (f : B -> C -> D -> Lwt.t (Error_monad.tzresult E)) : unit :=
  Pervasives.op_coloneq rpc_services
    (RPC_directory.register (Pervasives.op_exclamation rpc_services) s
      (fun function_parameter =>
        let '(_, arg) := function_parameter in
        fun q => fun i => f arg q i)).

Definition register2_fullctxt {A B C D E : Set}
  (s :
    RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) Updater.rpc_context
      ((Updater.rpc_context * A) * B) C D E)
  (f : rpc_context -> A -> B -> C -> D -> Lwt.t (Error_monad.tzresult E))
  : unit :=
  Pervasives.op_coloneq rpc_services
    (RPC_directory.register (Pervasives.op_exclamation rpc_services) s
      (fun function_parameter =>
        let '((ctxt, arg1), arg2) := function_parameter in
        fun q =>
          fun i =>
            Error_monad.op_gtgteqquestion (rpc_init ctxt)
              (fun ctxt => f ctxt arg1 arg2 q i))).

Definition register2 {A B C D E : Set}
  (s :
    RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) Updater.rpc_context
      ((Updater.rpc_context * A) * B) C D E)
  (f : Alpha_context.t -> A -> B -> C -> D -> Lwt.t (Error_monad.tzresult E))
  : unit :=
  register2_fullctxt s
    (fun function_parameter =>
      let '{| rpc_context.context := context |} := function_parameter in
      fun a1 => fun a2 => fun q => fun i => f context a1 a2 q i).

Definition get_rpc_services (function_parameter : unit)
  : RPC_directory.directory Updater.rpc_context :=
  let '_ := function_parameter in
  let p :=
    RPC_directory.map
      (fun c =>
        Error_monad.op_gtgteq (rpc_init c)
          (fun function_parameter =>
            match function_parameter with
            | Pervasives.Error _ =>
              (* ❌ Assert instruction is not handled. *)
              assert false
            | Pervasives.Ok c => Lwt.__return (rpc_context.context c)
            end))
      (Storage_description.build_directory Alpha_context.description) in
  RPC_directory.register_dynamic_directory None
    (Pervasives.op_exclamation rpc_services)
    (RPC_path.op_div
      (RPC_path.op_div (RPC_path.op_div RPC_path.open_root "context") "raw")
      "json")
    (fun function_parameter =>
      let '_ := function_parameter in
      Lwt.__return p).

State_hash

  • OCaml size: 43 lines
  • Coq size: 103 lines (+139% compared to OCaml)
state_hash.ml 1 error 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let random_state_hash = "\076\064\204" (* rng(53): never used... *)

module Blake2BModule =
  Blake2B.Make
    (Base58)
    (struct
      let name = "random"

      let title = "A random generation state"

      let b58check_prefix = random_state_hash

      let size = None
    end)

include Blake2BModule

let () = Base58.check_encoded_prefix b58check_encoding "rng" 53
State_hash.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Definition random_state_hash : string := "L@\204".

Definition Blake2BModule :=
  (Blake2B.Make
    (existT (fun _ => _) tt
      {|
        Blake2B.SRegister.register_encoding {_} := Base58.register_encoding
      |}))
    (let name := "random" in
    let title := "A random generation state" in
    let b58check_prefix := random_state_hash in
    let size := None in
    existT (fun _ => _) tt
      {|
        Blake2B.PrefixedName.name := name;
        Blake2B.PrefixedName.title := title;
        Blake2B.PrefixedName.size := size;
        Blake2B.PrefixedName.b58check_prefix := b58check_prefix
      |}).

Definition t := (|Blake2BModule|).(S.HASH.t).

Definition name := (|Blake2BModule|).(S.HASH.name).

Definition title := (|Blake2BModule|).(S.HASH.title).

Definition pp := (|Blake2BModule|).(S.HASH.pp).

Definition pp_short := (|Blake2BModule|).(S.HASH.pp_short).

Definition op_eq := (|Blake2BModule|).(S.HASH.op_eq).

Definition op_ltgt := (|Blake2BModule|).(S.HASH.op_ltgt).

Definition op_lt := (|Blake2BModule|).(S.HASH.op_lt).

Definition op_lteq := (|Blake2BModule|).(S.HASH.op_lteq).

Definition op_gteq := (|Blake2BModule|).(S.HASH.op_gteq).

Definition op_gt := (|Blake2BModule|).(S.HASH.op_gt).

Definition compare := (|Blake2BModule|).(S.HASH.compare).

Definition equal := (|Blake2BModule|).(S.HASH.equal).

Definition max := (|Blake2BModule|).(S.HASH.max).

Definition min := (|Blake2BModule|).(S.HASH.min).

Definition hash_bytes := (|Blake2BModule|).(S.HASH.hash_bytes).

Definition hash_string := (|Blake2BModule|).(S.HASH.hash_string).

Definition zero := (|Blake2BModule|).(S.HASH.zero).

Definition size := (|Blake2BModule|).(S.HASH.size).

Definition to_bytes := (|Blake2BModule|).(S.HASH.to_bytes).

Definition of_bytes_opt := (|Blake2BModule|).(S.HASH.of_bytes_opt).

Definition of_bytes_exn := (|Blake2BModule|).(S.HASH.of_bytes_exn).

Definition to_b58check := (|Blake2BModule|).(S.HASH.to_b58check).

Definition to_short_b58check := (|Blake2BModule|).(S.HASH.to_short_b58check).

Definition of_b58check_exn := (|Blake2BModule|).(S.HASH.of_b58check_exn).

Definition of_b58check_opt := (|Blake2BModule|).(S.HASH.of_b58check_opt).

Definition b58check_encoding := (|Blake2BModule|).(S.HASH.b58check_encoding).

Definition encoding := (|Blake2BModule|).(S.HASH.encoding).

Definition rpc_arg := (|Blake2BModule|).(S.HASH.rpc_arg).

Definition to_path := (|Blake2BModule|).(S.HASH.to_path).

Definition of_path := (|Blake2BModule|).(S.HASH.of_path).

Definition of_path_exn := (|Blake2BModule|).(S.HASH.of_path_exn).

Definition prefix_path := (|Blake2BModule|).(S.HASH.prefix_path).

Definition path_length := (|Blake2BModule|).(S.HASH.path_length).

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Storage

  • OCaml size: 891 lines
  • Coq size: 2817 lines (+216% compared to OCaml)
storage.ml 97 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Storage_functors

module Int = struct
  type t = int

  let encoding = Data_encoding.uint16
end

module Int32 = struct
  type t = Int32.t

  let encoding = Data_encoding.int32
end

module Z = struct
  include Z

  let encoding = Data_encoding.z
end

module Int_index = struct
  type t = int

  let path_length = 1

  let to_path c l = string_of_int c :: l

  let of_path = function
    | [] | _ :: _ :: _ ->
        None
    | [c] ->
        int_of_string_opt c

  type 'a ipath = 'a * t

  let args =
    Storage_description.One
      {
        rpc_arg = RPC_arg.int;
        encoding = Data_encoding.int31;
        compare = Compare.Int.compare;
      }
end

module Make_index (H : Storage_description.INDEX) :
  INDEX with type t = H.t and type 'a ipath = 'a * H.t = struct
  include H

  type 'a ipath = 'a * t

  let args = Storage_description.One {rpc_arg; encoding; compare}
end

module Block_priority =
  Make_single_data_storage (Registered) (Raw_context)
    (struct
      let name = ["block_priority"]
    end)
    (Int)

(** Contracts handling *)

module Contract = struct
  module Raw_context =
    Make_subcontext (Registered) (Raw_context)
      (struct
        let name = ["contracts"]
      end)

  module Global_counter =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["global_counter"]
      end)
      (Z)

  module Indexed_context =
    Make_indexed_subcontext
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["index"]
         end))
         (Make_index (Contract_repr.Index))

  let fold = Indexed_context.fold_keys

  let list = Indexed_context.keys

  module Balance =
    Indexed_context.Make_map
      (struct
        let name = ["balance"]
      end)
      (Tez_repr)

  module Frozen_balance_index =
    Make_indexed_subcontext
      (Make_subcontext (Registered) (Indexed_context.Raw_context)
         (struct
           let name = ["frozen_balance"]
         end))
         (Make_index (Cycle_repr.Index))

  module Frozen_deposits =
    Frozen_balance_index.Make_map
      (struct
        let name = ["deposits"]
      end)
      (Tez_repr)

  module Frozen_fees =
    Frozen_balance_index.Make_map
      (struct
        let name = ["fees"]
      end)
      (Tez_repr)

  module Frozen_rewards =
    Frozen_balance_index.Make_map
      (struct
        let name = ["rewards"]
      end)
      (Tez_repr)

  module Manager =
    Indexed_context.Make_map
      (struct
        let name = ["manager"]
      end)
      (Manager_repr)

  module Delegate =
    Indexed_context.Make_map
      (struct
        let name = ["delegate"]
      end)
      (Signature.Public_key_hash)

  module Inactive_delegate =
    Indexed_context.Make_set
      (Registered)
      (struct
        let name = ["inactive_delegate"]
      end)

  module Delegate_desactivation =
    Indexed_context.Make_map
      (struct
        let name = ["delegate_desactivation"]
      end)
      (Cycle_repr)

  module Delegated =
    Make_data_set_storage
      (Make_subcontext (Registered) (Indexed_context.Raw_context)
         (struct
           let name = ["delegated"]
         end))
         (Make_index (Contract_repr.Index))

  module Counter =
    Indexed_context.Make_map
      (struct
        let name = ["counter"]
      end)
      (Z)

  (* Consume gas for serilization and deserialization of expr in this
     module *)
  module Make_carbonated_map_expr (N : Storage_sigs.NAME) = struct
    module I =
      Indexed_context.Make_carbonated_map
        (N)
        (struct
          type t = Script_repr.lazy_expr

          let encoding = Script_repr.lazy_expr_encoding
        end)

    type context = I.context

    type key = I.key

    type value = I.value

    let mem = I.mem

    let delete = I.delete

    let remove = I.remove

    let consume_deserialize_gas ctxt value =
      Lwt.return
      @@ ( Raw_context.check_enough_gas
             ctxt
             (Script_repr.minimal_deserialize_cost value)
         >>? fun () ->
         Script_repr.force_decode value
         >>? fun (_value, value_cost) ->
         Raw_context.consume_gas ctxt value_cost )

    let consume_serialize_gas ctxt value =
      Lwt.return
      @@ ( Script_repr.force_bytes value
         >>? fun (_value, value_cost) ->
         Raw_context.consume_gas ctxt value_cost )

    let get ctxt contract =
      I.get ctxt contract
      >>=? fun (ctxt, value) ->
      consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value)

    let get_option ctxt contract =
      I.get_option ctxt contract
      >>=? fun (ctxt, value_opt) ->
      match value_opt with
      | None ->
          return (ctxt, None)
      | Some value ->
          consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value_opt)

    let set ctxt contract value =
      consume_serialize_gas ctxt value
      >>=? fun ctxt -> I.set ctxt contract value

    let set_option ctxt contract value_opt =
      match value_opt with
      | None ->
          I.set_option ctxt contract None
      | Some value ->
          consume_serialize_gas ctxt value
          >>=? fun ctxt -> I.set_option ctxt contract value_opt

    let init ctxt contract value =
      consume_serialize_gas ctxt value
      >>=? fun ctxt -> I.init ctxt contract value

    let init_set ctxt contract value =
      consume_serialize_gas ctxt value
      >>=? fun ctxt -> I.init_set ctxt contract value
  end

  module Code = Make_carbonated_map_expr (struct
    let name = ["code"]
  end)

  module Storage = Make_carbonated_map_expr (struct
    let name = ["storage"]
  end)

  module Paid_storage_space =
    Indexed_context.Make_map
      (struct
        let name = ["paid_bytes"]
      end)
      (Z)

  module Used_storage_space =
    Indexed_context.Make_map
      (struct
        let name = ["used_bytes"]
      end)
      (Z)

  module Roll_list =
    Indexed_context.Make_map
      (struct
        let name = ["roll_list"]
      end)
      (Roll_repr)

  module Change =
    Indexed_context.Make_map
      (struct
        let name = ["change"]
      end)
      (Tez_repr)
end

(** Big maps handling *)

module Big_map = struct
  module Raw_context =
    Make_subcontext (Registered) (Raw_context)
      (struct
        let name = ["big_maps"]
      end)

  module Next = struct
    module Single_data_storage =
      Make_single_data_storage (Registered) (Raw_context)
        (struct
          let name = ["next"]
        end)
        (Z)

    include Single_data_storage

    let incr ctxt =
      get ctxt
      >>=? fun i -> set ctxt (Z.succ i) >>=? fun ctxt -> return (ctxt, i)

    let init ctxt = init ctxt Z.zero
  end

  module Index = struct
    type t = Z.t

    let rpc_arg =
      let construct = Z.to_string in
      let destruct hash =
        match Z.of_string hash with
        | exception _ ->
            Error "Cannot parse big map id"
        | id ->
            Ok id
      in
      RPC_arg.make
        ~descr:"A big map identifier"
        ~name:"big_map_id"
        ~construct
        ~destruct
        ()

    let encoding =
      Data_encoding.def
        "big_map_id"
        ~title:"Big map identifier"
        ~description:"A big map identifier"
        Z.encoding

    let compare = Compare.Z.compare

    let path_length = 7

    let to_path c l =
      let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in
      let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
      String.sub index_key 0 2 :: String.sub index_key 2 2
      :: String.sub index_key 4 2 :: String.sub index_key 6 2
      :: String.sub index_key 8 2 :: String.sub index_key 10 2 :: Z.to_string c
      :: l

    let of_path = function
      | []
      | [_]
      | [_; _]
      | [_; _; _]
      | [_; _; _; _]
      | [_; _; _; _; _]
      | [_; _; _; _; _; _]
      | _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ ->
          None
      | [index1; index2; index3; index4; index5; index6; key] ->
          let c = Z.of_string key in
          let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in
          let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
          assert (Compare.String.(String.sub index_key 0 2 = index1)) ;
          assert (Compare.String.(String.sub index_key 2 2 = index2)) ;
          assert (Compare.String.(String.sub index_key 4 2 = index3)) ;
          assert (Compare.String.(String.sub index_key 6 2 = index4)) ;
          assert (Compare.String.(String.sub index_key 8 2 = index5)) ;
          assert (Compare.String.(String.sub index_key 10 2 = index6)) ;
          Some c
  end

  module Indexed_context =
    Make_indexed_subcontext
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["index"]
         end))
         (Make_index (Index))

  let rpc_arg = Index.rpc_arg

  let fold = Indexed_context.fold_keys

  let list = Indexed_context.keys

  let remove_rec ctxt n = Indexed_context.remove_rec ctxt n

  let copy ctxt ~from ~to_ = Indexed_context.copy ctxt ~from ~to_

  type key = Raw_context.t * Z.t

  module Total_bytes =
    Indexed_context.Make_map
      (struct
        let name = ["total_bytes"]
      end)
      (Z)

  module Key_type =
    Indexed_context.Make_map
      (struct
        let name = ["key_type"]
      end)
      (struct
        type t = Script_repr.expr

        let encoding = Script_repr.expr_encoding
      end)

  module Value_type =
    Indexed_context.Make_map
      (struct
        let name = ["value_type"]
      end)
      (struct
        type t = Script_repr.expr

        let encoding = Script_repr.expr_encoding
      end)

  module Contents = struct
    module I =
      Storage_functors.Make_indexed_carbonated_data_storage
        (Make_subcontext (Registered) (Indexed_context.Raw_context)
           (struct
             let name = ["contents"]
           end))
           (Make_index (Script_expr_hash))
           (struct
             type t = Script_repr.expr

             let encoding = Script_repr.expr_encoding
           end)

    type context = I.context

    type key = I.key

    type value = I.value

    let mem = I.mem

    let delete = I.delete

    let remove = I.remove

    let set = I.set

    let set_option = I.set_option

    let init = I.init

    let init_set = I.init_set

    let consume_deserialize_gas ctxt value =
      Lwt.return
      @@ Raw_context.consume_gas ctxt (Script_repr.deserialized_cost value)

    let get ctxt contract =
      I.get ctxt contract
      >>=? fun (ctxt, value) ->
      consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value)

    let get_option ctxt contract =
      I.get_option ctxt contract
      >>=? fun (ctxt, value_opt) ->
      match value_opt with
      | None ->
          return (ctxt, None)
      | Some value ->
          consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value_opt)
  end
end

module Delegates =
  Make_data_set_storage
    (Make_subcontext (Registered) (Raw_context)
       (struct
         let name = ["delegates"]
       end))
       (Make_index (Signature.Public_key_hash))

module Active_delegates_with_rolls =
  Make_data_set_storage
    (Make_subcontext (Registered) (Raw_context)
       (struct
         let name = ["active_delegates_with_rolls"]
       end))
       (Make_index (Signature.Public_key_hash))

module Delegates_with_frozen_balance_index =
  Make_indexed_subcontext
    (Make_subcontext (Registered) (Raw_context)
       (struct
         let name = ["delegates_with_frozen_balance"]
       end))
       (Make_index (Cycle_repr.Index))

module Delegates_with_frozen_balance =
  Make_data_set_storage
    (Delegates_with_frozen_balance_index.Raw_context)
    (Make_index (Signature.Public_key_hash))

(** Rolls *)

module Cycle = struct
  module Indexed_context =
    Make_indexed_subcontext
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["cycle"]
         end))
         (Make_index (Cycle_repr.Index))

  module Last_roll =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Indexed_context.Raw_context)
         (struct
           let name = ["last_roll"]
         end))
         (Int_index)
      (Roll_repr)

  module Roll_snapshot =
    Indexed_context.Make_map
      (struct
        let name = ["roll_snapshot"]
      end)
      (Int)

  type unrevealed_nonce = {
    nonce_hash : Nonce_hash.t;
    delegate : Signature.Public_key_hash.t;
    rewards : Tez_repr.t;
    fees : Tez_repr.t;
  }

  type nonce_status =
    | Unrevealed of unrevealed_nonce
    | Revealed of Seed_repr.nonce

  let nonce_status_encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Unrevealed"
          (tup4
             Nonce_hash.encoding
             Signature.Public_key_hash.encoding
             Tez_repr.encoding
             Tez_repr.encoding)
          (function
            | Unrevealed {nonce_hash; delegate; rewards; fees} ->
                Some (nonce_hash, delegate, rewards, fees)
            | _ ->
                None)
          (fun (nonce_hash, delegate, rewards, fees) ->
            Unrevealed {nonce_hash; delegate; rewards; fees});
        case
          (Tag 1)
          ~title:"Revealed"
          Seed_repr.nonce_encoding
          (function Revealed nonce -> Some nonce | _ -> None)
          (fun nonce -> Revealed nonce) ]

  module Nonce =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Indexed_context.Raw_context)
         (struct
           let name = ["nonces"]
         end))
         (Make_index (Raw_level_repr.Index))
         (struct
           type t = nonce_status

           let encoding = nonce_status_encoding
         end)

  module Seed =
    Indexed_context.Make_map
      (struct
        let name = ["random_seed"]
      end)
      (struct
        type t = Seed_repr.seed

        let encoding = Seed_repr.seed_encoding
      end)
end

module Roll = struct
  module Raw_context =
    Make_subcontext (Registered) (Raw_context)
      (struct
        let name = ["rolls"]
      end)

  module Indexed_context =
    Make_indexed_subcontext
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["index"]
         end))
         (Make_index (Roll_repr.Index))

  module Next =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["next"]
      end)
      (Roll_repr)

  module Limbo =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["limbo"]
      end)
      (Roll_repr)

  module Delegate_roll_list =
    Wrap_indexed_data_storage
      (Contract.Roll_list)
      (struct
        type t = Signature.Public_key_hash.t

        let wrap = Contract_repr.implicit_contract

        let unwrap = Contract_repr.is_implicit
      end)

  module Successor =
    Indexed_context.Make_map
      (struct
        let name = ["successor"]
      end)
      (Roll_repr)

  module Delegate_change =
    Wrap_indexed_data_storage
      (Contract.Change)
      (struct
        type t = Signature.Public_key_hash.t

        let wrap = Contract_repr.implicit_contract

        let unwrap = Contract_repr.is_implicit
      end)

  module Snapshoted_owner_index = struct
    type t = Cycle_repr.t * int

    let path_length = Cycle_repr.Index.path_length + 1

    let to_path (c, n) s = Cycle_repr.Index.to_path c (string_of_int n :: s)

    let of_path l =
      match Misc.take Cycle_repr.Index.path_length l with
      | None | Some (_, ([] | _ :: _ :: _)) ->
          None
      | Some (l1, [l2]) -> (
        match (Cycle_repr.Index.of_path l1, int_of_string_opt l2) with
        | (None, _) | (_, None) ->
            None
        | (Some c, Some i) ->
            Some (c, i) )

    type 'a ipath = ('a * Cycle_repr.t) * int

    let left_args =
      Storage_description.One
        {
          rpc_arg = Cycle_repr.rpc_arg;
          encoding = Cycle_repr.encoding;
          compare = Cycle_repr.compare;
        }

    let right_args =
      Storage_description.One
        {
          rpc_arg = RPC_arg.int;
          encoding = Data_encoding.int31;
          compare = Compare.Int.compare;
        }

    let args = Storage_description.(Pair (left_args, right_args))
  end

  module Owner =
    Make_indexed_data_snapshotable_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["owner"]
         end))
         (Snapshoted_owner_index)
      (Make_index (Roll_repr.Index))
      (Signature.Public_key)

  module Snapshot_for_cycle = Cycle.Roll_snapshot
  module Last_for_snapshot = Cycle.Last_roll

  let clear = Indexed_context.clear
end

(** Votes *)

module Vote = struct
  module Raw_context =
    Make_subcontext (Registered) (Raw_context)
      (struct
        let name = ["votes"]
      end)

  module Current_period_kind =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["current_period_kind"]
      end)
      (struct
        type t = Voting_period_repr.kind

        let encoding = Voting_period_repr.kind_encoding
      end)

  module Participation_ema =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["participation_ema"]
      end)
      (Int32)

  module Current_proposal =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["current_proposal"]
      end)
      (Protocol_hash)

  module Listings_size =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["listings_size"]
      end)
      (Int32)

  module Listings =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["listings"]
         end))
         (Make_index (Signature.Public_key_hash))
         (Int32)

  module Proposals =
    Make_data_set_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["proposals"]
         end))
         (Pair
            (Make_index
               (Protocol_hash))
               (Make_index (Signature.Public_key_hash)))

  module Proposals_count =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["proposals_count"]
         end))
         (Make_index (Signature.Public_key_hash))
         (Int)

  module Ballots =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["ballots"]
         end))
         (Make_index (Signature.Public_key_hash))
         (struct
           type t = Vote_repr.ballot

           let encoding = Vote_repr.ballot_encoding
         end)
end

(** Seed *)

module Seed = struct
  type unrevealed_nonce = Cycle.unrevealed_nonce = {
    nonce_hash : Nonce_hash.t;
    delegate : Signature.Public_key_hash.t;
    rewards : Tez_repr.t;
    fees : Tez_repr.t;
  }

  type nonce_status = Cycle.nonce_status =
    | Unrevealed of unrevealed_nonce
    | Revealed of Seed_repr.nonce

  module Nonce = struct
    open Level_repr

    type context = Raw_context.t

    let mem ctxt l = Cycle.Nonce.mem (ctxt, l.cycle) l.level

    let get ctxt l = Cycle.Nonce.get (ctxt, l.cycle) l.level

    let get_option ctxt l = Cycle.Nonce.get_option (ctxt, l.cycle) l.level

    let set ctxt l v = Cycle.Nonce.set (ctxt, l.cycle) l.level v

    let init ctxt l v = Cycle.Nonce.init (ctxt, l.cycle) l.level v

    let init_set ctxt l v = Cycle.Nonce.init_set (ctxt, l.cycle) l.level v

    let set_option ctxt l v = Cycle.Nonce.set_option (ctxt, l.cycle) l.level v

    let delete ctxt l = Cycle.Nonce.delete (ctxt, l.cycle) l.level

    let remove ctxt l = Cycle.Nonce.remove (ctxt, l.cycle) l.level
  end

  module For_cycle = Cycle.Seed
end

(** Commitments *)

module Commitments =
  Make_indexed_data_storage
    (Make_subcontext (Registered) (Raw_context)
       (struct
         let name = ["commitments"]
       end))
       (Make_index (Blinded_public_key_hash.Index))
       (Tez_repr)

(** Ramp up security deposits... *)

module Ramp_up = struct
  module Rewards =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["ramp_up"; "rewards"]
         end))
         (Make_index (Cycle_repr.Index))
         (struct
           type t = Tez_repr.t * Tez_repr.t

           let encoding =
             Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding
         end)

  module Security_deposits =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["ramp_up"; "deposits"]
         end))
         (Make_index (Cycle_repr.Index))
         (struct
           type t = Tez_repr.t * Tez_repr.t

           let encoding =
             Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding
         end)
end
Storage.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Blinded_public_key_hash.
Require Tezos.Contract_repr.
Require Tezos.Cycle_repr.
Require Tezos.Gas_limit_repr.
Require Tezos.Level_repr.
Require Tezos.Misc.
Require Tezos.Nonce_hash.
Require Tezos.Raw_context.
Require Tezos.Raw_level_repr.
Require Tezos.Roll_repr.
Require Tezos.Script_expr_hash.
Require Tezos.Script_repr.
Require Tezos.Seed_repr.
Require Tezos.Storage_description.
Require Tezos.Storage_functors.
Require Tezos.Storage_sigs.
Require Tezos.Tez_repr.
Require Tezos.Vote_repr.
Require Tezos.Voting_period_repr.

Import Storage_functors.

Module Int.
  Definition t := Z.
  
  Definition encoding : Data_encoding.encoding Z := Data_encoding.uint16.
End Int.

Module Int32.
  Definition t := Int32.t.
  
  Definition encoding : Data_encoding.encoding int32 :=
    Data_encoding.__int32_value.
End Int32.

Module Z.
  Include Z.
  
  Definition encoding : Data_encoding.encoding Z.t := Data_encoding.z.
End Z.

Definition Int_index :=
  let t := Z in
  let path_length := 1 in
  let to_path (c : Z) (l : list string) : list string :=
    cons (Pervasives.string_of_int c) l in
  let of_path (function_parameter : list string) : option Z :=
    match function_parameter with
    | [] | cons _ (cons _ _) => None
    | cons c [] => Pervasives.int_of_string_opt c
    end in
  let ipath (a : Set) := a * t in
  let args :=
    Storage_description.One
      {| Storage_description.args.One.rpc_arg := RPC_arg.int;
        Storage_description.args.One.encoding := Data_encoding.int31;
        Storage_description.args.One.compare :=
          (|Compare.Int|).(Compare.S.compare) |} in
  existT (fun _ => _) tt
    {|
      Storage_functors.INDEX.path_length := path_length;
      Storage_functors.INDEX.to_path := to_path;
      Storage_functors.INDEX.of_path := of_path;
      Storage_functors.INDEX.args {_} := args
    |}.

Definition Make_index :=
  fun (H : {t : _ & Storage_description.INDEX.signature t}) =>
    (let t := (|H|).(Storage_description.INDEX.t) in
    let path_length := (|H|).(Storage_description.INDEX.path_length) in
    let to_path := (|H|).(Storage_description.INDEX.to_path) in
    let of_path := (|H|).(Storage_description.INDEX.of_path) in
    let rpc_arg := (|H|).(Storage_description.INDEX.rpc_arg) in
    let encoding := (|H|).(Storage_description.INDEX.encoding) in
    let compare := (|H|).(Storage_description.INDEX.compare) in
    let ipath (a : Set) := a * t in
    let args :=
      Storage_description.One
        {| Storage_description.args.One.rpc_arg := rpc_arg;
          Storage_description.args.One.encoding := encoding;
          Storage_description.args.One.compare := compare |} in
    existT (fun _ => _) tt
      {|
        Storage_functors.INDEX.path_length := path_length;
        Storage_functors.INDEX.to_path := to_path;
        Storage_functors.INDEX.of_path := of_path;
        Storage_functors.INDEX.args {_} := args
      |} :
      {_ : unit &
        INDEX.signature (|H|).(Storage_description.INDEX.t)
          (a * (|H|).(Storage_description.INDEX.t))}).

Definition Block_priority :=
  (((Storage_functors.Make_single_data_storage
    (existT (fun _ => _) tt
      {|
        Storage_sigs.REGISTER.ghost :=
          (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
      |}))
    (existT _ _
      {|
        Raw_context.T.mem := Raw_context.mem;
        Raw_context.T.dir_mem := Raw_context.dir_mem;
        Raw_context.T.get := Raw_context.get;
        Raw_context.T.get_option := Raw_context.get_option;
        Raw_context.T.init := Raw_context.init;
        Raw_context.T.set := Raw_context.set;
        Raw_context.T.init_set := Raw_context.init_set;
        Raw_context.T.set_option := Raw_context.set_option;
        Raw_context.T.delete := Raw_context.delete;
        Raw_context.T.remove := Raw_context.remove;
        Raw_context.T.remove_rec := Raw_context.remove_rec;
        Raw_context.T.copy := Raw_context.copy;
        Raw_context.T.fold {_} := Raw_context.fold;
        Raw_context.T.keys := Raw_context.keys;
        Raw_context.T.fold_keys {_} := Raw_context.fold_keys;
        Raw_context.T.project := Raw_context.project;
        Raw_context.T.absolute_key := Raw_context.absolute_key;
        Raw_context.T.consume_gas := Raw_context.consume_gas;
        Raw_context.T.check_enough_gas := Raw_context.check_enough_gas;
        Raw_context.T.description := Raw_context.description
      |}))
    (let name := [ "block_priority" ] in
    existT (fun _ => _) tt
      {|
        Storage_sigs.NAME.name := name
      |}))
    (existT _ _
      {|
        Storage_sigs.VALUE.encoding := (|Int|).(Storage_sigs.VALUE.encoding)
      |}).

Module Contract.
  Definition Raw_context :=
    ((Storage_functors.Make_subcontext
      (existT (fun _ => _) tt
        {|
          Storage_sigs.REGISTER.ghost :=
            (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
        |}))
      (existT _ _
        {|
          Raw_context.T.mem := Raw_context.mem;
          Raw_context.T.dir_mem := Raw_context.dir_mem;
          Raw_context.T.get := Raw_context.get;
          Raw_context.T.get_option := Raw_context.get_option;
          Raw_context.T.init := Raw_context.init;
          Raw_context.T.set := Raw_context.set;
          Raw_context.T.init_set := Raw_context.init_set;
          Raw_context.T.set_option := Raw_context.set_option;
          Raw_context.T.delete := Raw_context.delete;
          Raw_context.T.remove := Raw_context.remove;
          Raw_context.T.remove_rec := Raw_context.remove_rec;
          Raw_context.T.copy := Raw_context.copy;
          Raw_context.T.fold {_} := Raw_context.fold;
          Raw_context.T.keys := Raw_context.keys;
          Raw_context.T.fold_keys {_} := Raw_context.fold_keys;
          Raw_context.T.project := Raw_context.project;
          Raw_context.T.absolute_key := Raw_context.absolute_key;
          Raw_context.T.consume_gas := Raw_context.consume_gas;
          Raw_context.T.check_enough_gas := Raw_context.check_enough_gas;
          Raw_context.T.description := Raw_context.description
        |}))
      (let name := [ "contracts" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}).
  
  Definition Global_counter :=
    (((Storage_functors.Make_single_data_storage
      (existT (fun _ => _) tt
        {|
          Storage_sigs.REGISTER.ghost :=
            (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
        |}))
      (existT _ _
        {|
          Raw_context.T.mem := (|Raw_context|).(Raw_context.T.mem);
          Raw_context.T.dir_mem := (|Raw_context|).(Raw_context.T.dir_mem);
          Raw_context.T.get := (|Raw_context|).(Raw_context.T.get);
          Raw_context.T.get_option := (|Raw_context|).(Raw_context.T.get_option);
          Raw_context.T.init := (|Raw_context|).(Raw_context.T.init);
          Raw_context.T.set := (|Raw_context|).(Raw_context.T.set);
          Raw_context.T.init_set := (|Raw_context|).(Raw_context.T.init_set);
          Raw_context.T.set_option := (|Raw_context|).(Raw_context.T.set_option);
          Raw_context.T.delete := (|Raw_context|).(Raw_context.T.delete);
          Raw_context.T.remove := (|Raw_context|).(Raw_context.T.remove);
          Raw_context.T.remove_rec := (|Raw_context|).(Raw_context.T.remove_rec);
          Raw_context.T.copy := (|Raw_context|).(Raw_context.T.copy);
          Raw_context.T.fold {_} := (|Raw_context|).(Raw_context.T.fold);
          Raw_context.T.keys := (|Raw_context|).(Raw_context.T.keys);
          Raw_context.T.fold_keys {_} :=
            (|Raw_context|).(Raw_context.T.fold_keys);
          Raw_context.T.project := (|Raw_context|).(Raw_context.T.project);
          Raw_context.T.absolute_key :=
            (|Raw_context|).(Raw_context.T.absolute_key);
          Raw_context.T.consume_gas :=
            (|Raw_context|).(Raw_context.T.consume_gas);
          Raw_context.T.check_enough_gas :=
            (|Raw_context|).(Raw_context.T.check_enough_gas);
          Raw_context.T.description :=
            (|Raw_context|).(Raw_context.T.description)
        |}))
      (let name := [ "global_counter" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := Z.encoding
        |}).
  
  Definition Indexed_context :=
    (Storage_functors.Make_indexed_subcontext
      (((Storage_functors.Make_subcontext
        (existT (fun _ => _) tt
          {|
            Storage_sigs.REGISTER.ghost :=
              (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
          |}))
        (existT _ _
          {|
            Raw_context.T.mem := (|Raw_context|).(Raw_context.T.mem);
            Raw_context.T.dir_mem := (|Raw_context|).(Raw_context.T.dir_mem);
            Raw_context.T.get := (|Raw_context|).(Raw_context.T.get);
            Raw_context.T.get_option :=
              (|Raw_context|).(Raw_context.T.get_option);
            Raw_context.T.init := (|Raw_context|).(Raw_context.T.init);
            Raw_context.T.set := (|Raw_context|).(Raw_context.T.set);
            Raw_context.T.init_set := (|Raw_context|).(Raw_context.T.init_set);
            Raw_context.T.set_option :=
              (|Raw_context|).(Raw_context.T.set_option);
            Raw_context.T.delete := (|Raw_context|).(Raw_context.T.delete);
            Raw_context.T.remove := (|Raw_context|).(Raw_context.T.remove);
            Raw_context.T.remove_rec :=
              (|Raw_context|).(Raw_context.T.remove_rec);
            Raw_context.T.copy := (|Raw_context|).(Raw_context.T.copy);
            Raw_context.T.fold {_} := (|Raw_context|).(Raw_context.T.fold);
            Raw_context.T.keys := (|Raw_context|).(Raw_context.T.keys);
            Raw_context.T.fold_keys {_} :=
              (|Raw_context|).(Raw_context.T.fold_keys);
            Raw_context.T.project := (|Raw_context|).(Raw_context.T.project);
            Raw_context.T.absolute_key :=
              (|Raw_context|).(Raw_context.T.absolute_key);
            Raw_context.T.consume_gas :=
              (|Raw_context|).(Raw_context.T.consume_gas);
            Raw_context.T.check_enough_gas :=
              (|Raw_context|).(Raw_context.T.check_enough_gas);
            Raw_context.T.description :=
              (|Raw_context|).(Raw_context.T.description)
          |}))
        (let name := [ "index" ] in
        existT (fun _ => _) tt
          {|
            Storage_sigs.NAME.name := name
          |})))
      (Make_index
        (existT _ _
          {|
            Storage_description.INDEX.path_length :=
              (|Contract_repr.Index|).(Storage_description.INDEX.path_length);
            Storage_description.INDEX.to_path :=
              (|Contract_repr.Index|).(Storage_description.INDEX.to_path);
            Storage_description.INDEX.of_path :=
              (|Contract_repr.Index|).(Storage_description.INDEX.of_path);
            Storage_description.INDEX.rpc_arg :=
              (|Contract_repr.Index|).(Storage_description.INDEX.rpc_arg);
            Storage_description.INDEX.encoding :=
              (|Contract_repr.Index|).(Storage_description.INDEX.encoding);
            Storage_description.INDEX.compare :=
              (|Contract_repr.Index|).(Storage_description.INDEX.compare)
          |})).
  
  Definition fold {A : Set}
    : (|Indexed_context|).(Storage_sigs.Indexed_raw_context.context) -> A ->
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.key) -> A -> Lwt.t A)
    -> Lwt.t A :=
    (|Indexed_context|).(Storage_sigs.Indexed_raw_context.fold_keys).
  
  Definition __list_value
    : (|Indexed_context|).(Storage_sigs.Indexed_raw_context.context) ->
    Lwt.t (list (|Indexed_context|).(Storage_sigs.Indexed_raw_context.key)) :=
    (|Indexed_context|).(Storage_sigs.Indexed_raw_context.keys).
  
  Definition Balance :=
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "balance" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := Tez_repr.encoding
        |}).
  
  Definition Frozen_balance_index :=
    (Storage_functors.Make_indexed_subcontext
      (((Storage_functors.Make_subcontext
        (existT (fun _ => _) tt
          {|
            Storage_sigs.REGISTER.ghost :=
              (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
          |}))
        (existT _ _
          {|
            Raw_context.T.mem :=
              (|Indexed_context.Raw_context|).(Raw_context.T.mem);
            Raw_context.T.dir_mem :=
              (|Indexed_context.Raw_context|).(Raw_context.T.dir_mem);
            Raw_context.T.get :=
              (|Indexed_context.Raw_context|).(Raw_context.T.get);
            Raw_context.T.get_option :=
              (|Indexed_context.Raw_context|).(Raw_context.T.get_option);
            Raw_context.T.init :=
              (|Indexed_context.Raw_context|).(Raw_context.T.init);
            Raw_context.T.set :=
              (|Indexed_context.Raw_context|).(Raw_context.T.set);
            Raw_context.T.init_set :=
              (|Indexed_context.Raw_context|).(Raw_context.T.init_set);
            Raw_context.T.set_option :=
              (|Indexed_context.Raw_context|).(Raw_context.T.set_option);
            Raw_context.T.delete :=
              (|Indexed_context.Raw_context|).(Raw_context.T.delete);
            Raw_context.T.remove :=
              (|Indexed_context.Raw_context|).(Raw_context.T.remove);
            Raw_context.T.remove_rec :=
              (|Indexed_context.Raw_context|).(Raw_context.T.remove_rec);
            Raw_context.T.copy :=
              (|Indexed_context.Raw_context|).(Raw_context.T.copy);
            Raw_context.T.fold {_} :=
              (|Indexed_context.Raw_context|).(Raw_context.T.fold);
            Raw_context.T.keys :=
              (|Indexed_context.Raw_context|).(Raw_context.T.keys);
            Raw_context.T.fold_keys {_} :=
              (|Indexed_context.Raw_context|).(Raw_context.T.fold_keys);
            Raw_context.T.project :=
              (|Indexed_context.Raw_context|).(Raw_context.T.project);
            Raw_context.T.absolute_key :=
              (|Indexed_context.Raw_context|).(Raw_context.T.absolute_key);
            Raw_context.T.consume_gas :=
              (|Indexed_context.Raw_context|).(Raw_context.T.consume_gas);
            Raw_context.T.check_enough_gas :=
              (|Indexed_context.Raw_context|).(Raw_context.T.check_enough_gas);
            Raw_context.T.description :=
              (|Indexed_context.Raw_context|).(Raw_context.T.description)
          |}))
        (let name := [ "frozen_balance" ] in
        existT (fun _ => _) tt
          {|
            Storage_sigs.NAME.name := name
          |})))
      (Make_index
        (existT _ _
          {|
            Storage_description.INDEX.path_length :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.path_length);
            Storage_description.INDEX.to_path :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.to_path);
            Storage_description.INDEX.of_path :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.of_path);
            Storage_description.INDEX.rpc_arg :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.rpc_arg);
            Storage_description.INDEX.encoding :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.encoding);
            Storage_description.INDEX.compare :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.compare)
          |})).
  
  Definition Frozen_deposits :=
    ((|Frozen_balance_index|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "deposits" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := Tez_repr.encoding
        |}).
  
  Definition Frozen_fees :=
    ((|Frozen_balance_index|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "fees" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := Tez_repr.encoding
        |}).
  
  Definition Frozen_rewards :=
    ((|Frozen_balance_index|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "rewards" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := Tez_repr.encoding
        |}).
  
  Definition Manager :=
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "manager" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding :=
            (|Manager_repr|).(Storage_sigs.VALUE.encoding)
        |}).
  
  Definition Delegate :=
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "delegate" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding)
        |}).
  
  Definition Inactive_delegate :=
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.Make_set)
      (existT (fun _ => _) tt
        {|
          Storage_sigs.REGISTER.ghost :=
            (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
        |}))
      (let name := [ "inactive_delegate" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}).
  
  Definition Delegate_desactivation :=
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "delegate_desactivation" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := Cycle_repr.encoding
        |}).
  
  Definition Delegated :=
    (Storage_functors.Make_data_set_storage
      (((Storage_functors.Make_subcontext
        (existT (fun _ => _) tt
          {|
            Storage_sigs.REGISTER.ghost :=
              (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
          |}))
        (existT _ _
          {|
            Raw_context.T.mem :=
              (|Indexed_context.Raw_context|).(Raw_context.T.mem);
            Raw_context.T.dir_mem :=
              (|Indexed_context.Raw_context|).(Raw_context.T.dir_mem);
            Raw_context.T.get :=
              (|Indexed_context.Raw_context|).(Raw_context.T.get);
            Raw_context.T.get_option :=
              (|Indexed_context.Raw_context|).(Raw_context.T.get_option);
            Raw_context.T.init :=
              (|Indexed_context.Raw_context|).(Raw_context.T.init);
            Raw_context.T.set :=
              (|Indexed_context.Raw_context|).(Raw_context.T.set);
            Raw_context.T.init_set :=
              (|Indexed_context.Raw_context|).(Raw_context.T.init_set);
            Raw_context.T.set_option :=
              (|Indexed_context.Raw_context|).(Raw_context.T.set_option);
            Raw_context.T.delete :=
              (|Indexed_context.Raw_context|).(Raw_context.T.delete);
            Raw_context.T.remove :=
              (|Indexed_context.Raw_context|).(Raw_context.T.remove);
            Raw_context.T.remove_rec :=
              (|Indexed_context.Raw_context|).(Raw_context.T.remove_rec);
            Raw_context.T.copy :=
              (|Indexed_context.Raw_context|).(Raw_context.T.copy);
            Raw_context.T.fold {_} :=
              (|Indexed_context.Raw_context|).(Raw_context.T.fold);
            Raw_context.T.keys :=
              (|Indexed_context.Raw_context|).(Raw_context.T.keys);
            Raw_context.T.fold_keys {_} :=
              (|Indexed_context.Raw_context|).(Raw_context.T.fold_keys);
            Raw_context.T.project :=
              (|Indexed_context.Raw_context|).(Raw_context.T.project);
            Raw_context.T.absolute_key :=
              (|Indexed_context.Raw_context|).(Raw_context.T.absolute_key);
            Raw_context.T.consume_gas :=
              (|Indexed_context.Raw_context|).(Raw_context.T.consume_gas);
            Raw_context.T.check_enough_gas :=
              (|Indexed_context.Raw_context|).(Raw_context.T.check_enough_gas);
            Raw_context.T.description :=
              (|Indexed_context.Raw_context|).(Raw_context.T.description)
          |}))
        (let name := [ "delegated" ] in
        existT (fun _ => _) tt
          {|
            Storage_sigs.NAME.name := name
          |})))
      (Make_index
        (existT _ _
          {|
            Storage_description.INDEX.path_length :=
              (|Contract_repr.Index|).(Storage_description.INDEX.path_length);
            Storage_description.INDEX.to_path :=
              (|Contract_repr.Index|).(Storage_description.INDEX.to_path);
            Storage_description.INDEX.of_path :=
              (|Contract_repr.Index|).(Storage_description.INDEX.of_path);
            Storage_description.INDEX.rpc_arg :=
              (|Contract_repr.Index|).(Storage_description.INDEX.rpc_arg);
            Storage_description.INDEX.encoding :=
              (|Contract_repr.Index|).(Storage_description.INDEX.encoding);
            Storage_description.INDEX.compare :=
              (|Contract_repr.Index|).(Storage_description.INDEX.compare)
          |})).
  
  Definition Counter :=
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "counter" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := Z.encoding
        |}).
  
  Definition Make_carbonated_map_expr :=
    fun (N : {_ : unit & Storage_sigs.NAME.signature}) =>
      (* ❌ The signature name of this module could not be found *)
      first_class_module_value_of_unknown_signature.
  
  Definition Code :=
    Make_carbonated_map_expr
      (let name := [ "code" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}).
  
  Definition Storage :=
    Make_carbonated_map_expr
      (let name := [ "storage" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}).
  
  Definition Paid_storage_space :=
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "paid_bytes" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := Z.encoding
        |}).
  
  Definition Used_storage_space :=
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "used_bytes" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := Z.encoding
        |}).
  
  Definition Roll_list :=
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "roll_list" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := Roll_repr.encoding
        |}).
  
  Definition Change :=
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "change" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := Tez_repr.encoding
        |}).
End Contract.

Module Big_map.
  Definition Raw_context :=
    ((Storage_functors.Make_subcontext
      (existT (fun _ => _) tt
        {|
          Storage_sigs.REGISTER.ghost :=
            (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
        |}))
      (existT _ _
        {|
          Raw_context.T.mem := Raw_context.mem;
          Raw_context.T.dir_mem := Raw_context.dir_mem;
          Raw_context.T.get := Raw_context.get;
          Raw_context.T.get_option := Raw_context.get_option;
          Raw_context.T.init := Raw_context.init;
          Raw_context.T.set := Raw_context.set;
          Raw_context.T.init_set := Raw_context.init_set;
          Raw_context.T.set_option := Raw_context.set_option;
          Raw_context.T.delete := Raw_context.delete;
          Raw_context.T.remove := Raw_context.remove;
          Raw_context.T.remove_rec := Raw_context.remove_rec;
          Raw_context.T.copy := Raw_context.copy;
          Raw_context.T.fold {_} := Raw_context.fold;
          Raw_context.T.keys := Raw_context.keys;
          Raw_context.T.fold_keys {_} := Raw_context.fold_keys;
          Raw_context.T.project := Raw_context.project;
          Raw_context.T.absolute_key := Raw_context.absolute_key;
          Raw_context.T.consume_gas := Raw_context.consume_gas;
          Raw_context.T.check_enough_gas := Raw_context.check_enough_gas;
          Raw_context.T.description := Raw_context.description
        |}))
      (let name := [ "big_maps" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}).
  
  Module Next.
    Definition Single_data_storage :=
      (((Storage_functors.Make_single_data_storage
        (existT (fun _ => _) tt
          {|
            Storage_sigs.REGISTER.ghost :=
              (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
          |}))
        (existT _ _
          {|
            Raw_context.T.mem := (|Raw_context|).(Raw_context.T.mem);
            Raw_context.T.dir_mem := (|Raw_context|).(Raw_context.T.dir_mem);
            Raw_context.T.get := (|Raw_context|).(Raw_context.T.get);
            Raw_context.T.get_option :=
              (|Raw_context|).(Raw_context.T.get_option);
            Raw_context.T.init := (|Raw_context|).(Raw_context.T.init);
            Raw_context.T.set := (|Raw_context|).(Raw_context.T.set);
            Raw_context.T.init_set := (|Raw_context|).(Raw_context.T.init_set);
            Raw_context.T.set_option :=
              (|Raw_context|).(Raw_context.T.set_option);
            Raw_context.T.delete := (|Raw_context|).(Raw_context.T.delete);
            Raw_context.T.remove := (|Raw_context|).(Raw_context.T.remove);
            Raw_context.T.remove_rec :=
              (|Raw_context|).(Raw_context.T.remove_rec);
            Raw_context.T.copy := (|Raw_context|).(Raw_context.T.copy);
            Raw_context.T.fold {_} := (|Raw_context|).(Raw_context.T.fold);
            Raw_context.T.keys := (|Raw_context|).(Raw_context.T.keys);
            Raw_context.T.fold_keys {_} :=
              (|Raw_context|).(Raw_context.T.fold_keys);
            Raw_context.T.project := (|Raw_context|).(Raw_context.T.project);
            Raw_context.T.absolute_key :=
              (|Raw_context|).(Raw_context.T.absolute_key);
            Raw_context.T.consume_gas :=
              (|Raw_context|).(Raw_context.T.consume_gas);
            Raw_context.T.check_enough_gas :=
              (|Raw_context|).(Raw_context.T.check_enough_gas);
            Raw_context.T.description :=
              (|Raw_context|).(Raw_context.T.description)
          |}))
        (let name := [ "next" ] in
        existT (fun _ => _) tt
          {|
            Storage_sigs.NAME.name := name
          |}))
        (existT _ _
          {|
            Storage_sigs.VALUE.encoding := Z.encoding
          |}).
    
    Definition t := (|Single_data_storage|).(Storage_sigs.Single_data_storage.t).
    
    Definition context :=
      (|Single_data_storage|).(Storage_sigs.Single_data_storage.context).
    
    Definition value :=
      (|Single_data_storage|).(Storage_sigs.Single_data_storage.value).
    
    Definition mem :=
      (|Single_data_storage|).(Storage_sigs.Single_data_storage.mem).
    
    Definition get :=
      (|Single_data_storage|).(Storage_sigs.Single_data_storage.get).
    
    Definition get_option :=
      (|Single_data_storage|).(Storage_sigs.Single_data_storage.get_option).
    
    Definition init :=
      (|Single_data_storage|).(Storage_sigs.Single_data_storage.init).
    
    Definition set :=
      (|Single_data_storage|).(Storage_sigs.Single_data_storage.set).
    
    Definition init_set :=
      (|Single_data_storage|).(Storage_sigs.Single_data_storage.init_set).
    
    Definition set_option :=
      (|Single_data_storage|).(Storage_sigs.Single_data_storage.set_option).
    
    Definition delete :=
      (|Single_data_storage|).(Storage_sigs.Single_data_storage.delete).
    
    Definition remove :=
      (|Single_data_storage|).(Storage_sigs.Single_data_storage.remove).
    
    Definition incr (ctxt : context)
      : Lwt.t (Error_monad.tzresult (Raw_context.t * value)) :=
      Error_monad.op_gtgteqquestion (get ctxt)
        (fun i =>
          Error_monad.op_gtgteqquestion (set ctxt (Z.succ i))
            (fun ctxt => Error_monad.__return (ctxt, i))).
    
    Definition init (ctxt : context)
      : Lwt.t (Error_monad.tzresult Raw_context.t) := init ctxt Z.zero.
  End Next.
  
  Definition Index :=
    let t := Z.t in
    let rpc_arg :=
      let construct := Z.to_string in
      let destruct (__hash_value : string) : Pervasives.result Z.t string :=
        let 'id := Z.of_string __hash_value in
        Pervasives.Ok id in
      RPC_arg.make (Some "A big map identifier") "big_map_id" destruct construct
        tt in
    let encoding :=
      Data_encoding.def "big_map_id" (Some "Big map identifier")
        (Some "A big map identifier") Z.encoding in
    let compare := (|Compare.Z|).(Compare.S.compare) in
    let path_length := 7 in
    let to_path (c : Z.t) (l : list string) : list string :=
      let raw_key := Data_encoding.Binary.to_bytes_exn encoding c in
      let 'MBytes.Hex index_key := MBytes.to_hex (Raw_hashes.blake2b raw_key) in
      cons (String.sub index_key 0 2)
        (cons (String.sub index_key 2 2)
          (cons (String.sub index_key 4 2)
            (cons (String.sub index_key 6 2)
              (cons (String.sub index_key 8 2)
                (cons (String.sub index_key 10 2) (cons (Z.to_string c) l))))))
      in
    let of_path (function_parameter : list (|Compare.String|).(Compare.S.t))
      : option Z.t :=
      match function_parameter with
      |
        [] | cons _ [] | cons _ (cons _ []) | cons _ (cons _ (cons _ [])) |
        cons _ (cons _ (cons _ (cons _ []))) |
        cons _ (cons _ (cons _ (cons _ (cons _ [])))) |
        cons _ (cons _ (cons _ (cons _ (cons _ (cons _ []))))) |
        cons _ (cons _ (cons _ (cons _ (cons _ (cons _ (cons _ (cons _ _)))))))
        => None
      |
        cons index1
          (cons index2
            (cons index3 (cons index4 (cons index5 (cons index6 (cons key []))))))
        =>
        let c := Z.of_string key in
        let raw_key := Data_encoding.Binary.to_bytes_exn encoding c in
        let 'MBytes.Hex index_key := MBytes.to_hex (Raw_hashes.blake2b raw_key)
          in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        (* ❌ instruction_sequence ";" *)
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        (* ❌ instruction_sequence ";" *)
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        (* ❌ instruction_sequence ";" *)
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        (* ❌ instruction_sequence ";" *)
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        (* ❌ instruction_sequence ";" *)
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        (* ❌ instruction_sequence ";" *)
        Some c
      end in
    existT (fun _ => _) tt
      {|
        Storage_description.INDEX.rpc_arg := rpc_arg;
        Storage_description.INDEX.encoding := encoding;
        Storage_description.INDEX.compare := compare;
        Storage_description.INDEX.path_length := path_length;
        Storage_description.INDEX.to_path := to_path;
        Storage_description.INDEX.of_path := of_path
      |}.
  
  Definition Indexed_context :=
    (Storage_functors.Make_indexed_subcontext
      (((Storage_functors.Make_subcontext
        (existT (fun _ => _) tt
          {|
            Storage_sigs.REGISTER.ghost :=
              (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
          |}))
        (existT _ _
          {|
            Raw_context.T.mem := (|Raw_context|).(Raw_context.T.mem);
            Raw_context.T.dir_mem := (|Raw_context|).(Raw_context.T.dir_mem);
            Raw_context.T.get := (|Raw_context|).(Raw_context.T.get);
            Raw_context.T.get_option :=
              (|Raw_context|).(Raw_context.T.get_option);
            Raw_context.T.init := (|Raw_context|).(Raw_context.T.init);
            Raw_context.T.set := (|Raw_context|).(Raw_context.T.set);
            Raw_context.T.init_set := (|Raw_context|).(Raw_context.T.init_set);
            Raw_context.T.set_option :=
              (|Raw_context|).(Raw_context.T.set_option);
            Raw_context.T.delete := (|Raw_context|).(Raw_context.T.delete);
            Raw_context.T.remove := (|Raw_context|).(Raw_context.T.remove);
            Raw_context.T.remove_rec :=
              (|Raw_context|).(Raw_context.T.remove_rec);
            Raw_context.T.copy := (|Raw_context|).(Raw_context.T.copy);
            Raw_context.T.fold {_} := (|Raw_context|).(Raw_context.T.fold);
            Raw_context.T.keys := (|Raw_context|).(Raw_context.T.keys);
            Raw_context.T.fold_keys {_} :=
              (|Raw_context|).(Raw_context.T.fold_keys);
            Raw_context.T.project := (|Raw_context|).(Raw_context.T.project);
            Raw_context.T.absolute_key :=
              (|Raw_context|).(Raw_context.T.absolute_key);
            Raw_context.T.consume_gas :=
              (|Raw_context|).(Raw_context.T.consume_gas);
            Raw_context.T.check_enough_gas :=
              (|Raw_context|).(Raw_context.T.check_enough_gas);
            Raw_context.T.description :=
              (|Raw_context|).(Raw_context.T.description)
          |}))
        (let name := [ "index" ] in
        existT (fun _ => _) tt
          {|
            Storage_sigs.NAME.name := name
          |})))
      (Make_index
        (existT _ _
          {|
            Storage_description.INDEX.path_length :=
              (|Index|).(Storage_description.INDEX.path_length);
            Storage_description.INDEX.to_path :=
              (|Index|).(Storage_description.INDEX.to_path);
            Storage_description.INDEX.of_path :=
              (|Index|).(Storage_description.INDEX.of_path);
            Storage_description.INDEX.rpc_arg :=
              (|Index|).(Storage_description.INDEX.rpc_arg);
            Storage_description.INDEX.encoding :=
              (|Index|).(Storage_description.INDEX.encoding);
            Storage_description.INDEX.compare :=
              (|Index|).(Storage_description.INDEX.compare)
          |})).
  
  Definition rpc_arg : RPC_arg.arg Z.t :=
    (|Index|).(Storage_description.INDEX.rpc_arg).
  
  Definition fold {A : Set}
    : (|Indexed_context|).(Storage_sigs.Indexed_raw_context.context) -> A ->
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.key) -> A -> Lwt.t A)
    -> Lwt.t A :=
    (|Indexed_context|).(Storage_sigs.Indexed_raw_context.fold_keys).
  
  Definition __list_value
    : (|Indexed_context|).(Storage_sigs.Indexed_raw_context.context) ->
    Lwt.t (list (|Indexed_context|).(Storage_sigs.Indexed_raw_context.key)) :=
    (|Indexed_context|).(Storage_sigs.Indexed_raw_context.keys).
  
  Definition remove_rec
    (ctxt : (|Indexed_context|).(Storage_sigs.Indexed_raw_context.context))
    (n : (|Indexed_context|).(Storage_sigs.Indexed_raw_context.key))
    : Lwt.t (|Indexed_context|).(Storage_sigs.Indexed_raw_context.context) :=
    (|Indexed_context|).(Storage_sigs.Indexed_raw_context.remove_rec) ctxt n.
  
  Definition copy
    (ctxt : (|Indexed_context|).(Storage_sigs.Indexed_raw_context.context))
    (from : (|Indexed_context|).(Storage_sigs.Indexed_raw_context.key))
    (to_ : (|Indexed_context|).(Storage_sigs.Indexed_raw_context.key))
    : Lwt.t
      (Error_monad.tzresult
        (|Indexed_context|).(Storage_sigs.Indexed_raw_context.context)) :=
    (|Indexed_context|).(Storage_sigs.Indexed_raw_context.copy) ctxt from to_.
  
  Definition key := (|Raw_context|).(Raw_context.T.t) * Z.t.
  
  Definition Total_bytes :=
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "total_bytes" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := Z.encoding
        |}).
  
  Definition Key_type :=
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "key_type" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (let t := Script_repr.expr in
      let encoding := Script_repr.expr_encoding in
      existT _ _
        {|
          Storage_sigs.VALUE.encoding := encoding
        |}).
  
  Definition Value_type :=
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "value_type" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (let t := Script_repr.expr in
      let encoding := Script_repr.expr_encoding in
      existT _ _
        {|
          Storage_sigs.VALUE.encoding := encoding
        |}).
  
  Module Contents.
    Definition I :=
      ((Storage_functors.Make_indexed_carbonated_data_storage
        (((Storage_functors.Make_subcontext
          (existT (fun _ => _) tt
            {|
              Storage_sigs.REGISTER.ghost :=
                (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
            |}))
          (existT _ _
            {|
              Raw_context.T.mem :=
                (|Indexed_context.Raw_context|).(Raw_context.T.mem);
              Raw_context.T.dir_mem :=
                (|Indexed_context.Raw_context|).(Raw_context.T.dir_mem);
              Raw_context.T.get :=
                (|Indexed_context.Raw_context|).(Raw_context.T.get);
              Raw_context.T.get_option :=
                (|Indexed_context.Raw_context|).(Raw_context.T.get_option);
              Raw_context.T.init :=
                (|Indexed_context.Raw_context|).(Raw_context.T.init);
              Raw_context.T.set :=
                (|Indexed_context.Raw_context|).(Raw_context.T.set);
              Raw_context.T.init_set :=
                (|Indexed_context.Raw_context|).(Raw_context.T.init_set);
              Raw_context.T.set_option :=
                (|Indexed_context.Raw_context|).(Raw_context.T.set_option);
              Raw_context.T.delete :=
                (|Indexed_context.Raw_context|).(Raw_context.T.delete);
              Raw_context.T.remove :=
                (|Indexed_context.Raw_context|).(Raw_context.T.remove);
              Raw_context.T.remove_rec :=
                (|Indexed_context.Raw_context|).(Raw_context.T.remove_rec);
              Raw_context.T.copy :=
                (|Indexed_context.Raw_context|).(Raw_context.T.copy);
              Raw_context.T.fold {_} :=
                (|Indexed_context.Raw_context|).(Raw_context.T.fold);
              Raw_context.T.keys :=
                (|Indexed_context.Raw_context|).(Raw_context.T.keys);
              Raw_context.T.fold_keys {_} :=
                (|Indexed_context.Raw_context|).(Raw_context.T.fold_keys);
              Raw_context.T.project :=
                (|Indexed_context.Raw_context|).(Raw_context.T.project);
              Raw_context.T.absolute_key :=
                (|Indexed_context.Raw_context|).(Raw_context.T.absolute_key);
              Raw_context.T.consume_gas :=
                (|Indexed_context.Raw_context|).(Raw_context.T.consume_gas);
              Raw_context.T.check_enough_gas :=
                (|Indexed_context.Raw_context|).(Raw_context.T.check_enough_gas);
              Raw_context.T.description :=
                (|Indexed_context.Raw_context|).(Raw_context.T.description)
            |}))
          (let name := [ "contents" ] in
          existT (fun _ => _) tt
            {|
              Storage_sigs.NAME.name := name
            |})))
        (Make_index
          (existT _ _
            {|
              Storage_description.INDEX.path_length :=
                Script_expr_hash.path_length;
              Storage_description.INDEX.to_path := Script_expr_hash.to_path;
              Storage_description.INDEX.of_path := Script_expr_hash.of_path;
              Storage_description.INDEX.rpc_arg := Script_expr_hash.rpc_arg;
              Storage_description.INDEX.encoding := Script_expr_hash.encoding;
              Storage_description.INDEX.compare := Script_expr_hash.compare
            |})))
        (let t := Script_repr.expr in
        let encoding := Script_repr.expr_encoding in
        existT _ _
          {|
            Storage_sigs.VALUE.encoding := encoding
          |}).
    
    Definition context := (|I|).(Storage_sigs.Single_data_storage.context).
    
    Definition key := (|I|).(Storage_sigs.Single_data_storage.key).
    
    Definition value := (|I|).(Storage_sigs.Single_data_storage.value).
    
    Definition mem
      : (|I|).(Storage_sigs.Single_data_storage.context) ->
      (|I|).(Storage_sigs.Single_data_storage.key) ->
      Lwt.t (Error_monad.tzresult (Raw_context.t * bool)) :=
      (|I|).(Storage_sigs.Single_data_storage.mem).
    
    Definition delete
      : (|I|).(Storage_sigs.Single_data_storage.context) ->
      (|I|).(Storage_sigs.Single_data_storage.key) ->
      Lwt.t (Error_monad.tzresult (Raw_context.t * Z)) :=
      (|I|).(Storage_sigs.Single_data_storage.delete).
    
    Definition remove
      : (|I|).(Storage_sigs.Single_data_storage.context) ->
      (|I|).(Storage_sigs.Single_data_storage.key) ->
      Lwt.t (Error_monad.tzresult (Raw_context.t * Z * bool)) :=
      (|I|).(Storage_sigs.Single_data_storage.remove).
    
    Definition set
      : (|I|).(Storage_sigs.Single_data_storage.context) ->
      (|I|).(Storage_sigs.Single_data_storage.key) ->
      (|I|).(Storage_sigs.Single_data_storage.value) ->
      Lwt.t (Error_monad.tzresult (Raw_context.t * Z)) :=
      (|I|).(Storage_sigs.Single_data_storage.set).
    
    Definition set_option
      : (|I|).(Storage_sigs.Single_data_storage.context) ->
      (|I|).(Storage_sigs.Single_data_storage.key) ->
      option (|I|).(Storage_sigs.Single_data_storage.value) ->
      Lwt.t (Error_monad.tzresult (Raw_context.t * Z * bool)) :=
      (|I|).(Storage_sigs.Single_data_storage.set_option).
    
    Definition init
      : (|I|).(Storage_sigs.Single_data_storage.context) ->
      (|I|).(Storage_sigs.Single_data_storage.key) ->
      (|I|).(Storage_sigs.Single_data_storage.value) ->
      Lwt.t (Error_monad.tzresult (Raw_context.t * Z)) :=
      (|I|).(Storage_sigs.Single_data_storage.init).
    
    Definition init_set
      : (|I|).(Storage_sigs.Single_data_storage.context) ->
      (|I|).(Storage_sigs.Single_data_storage.key) ->
      (|I|).(Storage_sigs.Single_data_storage.value) ->
      Lwt.t (Error_monad.tzresult (Raw_context.t * Z * bool)) :=
      (|I|).(Storage_sigs.Single_data_storage.init_set).
    
    Definition consume_deserialize_gas
      (ctxt : (|Raw_context|).(Raw_context.T.context))
      (value : Script_repr.expr)
      : Lwt.t (Error_monad.tzresult (|Raw_context|).(Raw_context.T.context)) :=
      Pervasives.op_atat Lwt.__return
        ((|Raw_context|).(Raw_context.T.consume_gas) ctxt
          (Script_repr.deserialized_cost value)).
    
    Definition get
      (ctxt : (|I|).(Storage_sigs.Single_data_storage.context))
      (contract : (|I|).(Storage_sigs.Single_data_storage.key))
      : Lwt.t
        (Error_monad.tzresult
          ((|Raw_context|).(Raw_context.T.context) *
            (|I|).(Storage_sigs.Single_data_storage.value))) :=
      Error_monad.op_gtgteqquestion
        ((|I|).(Storage_sigs.Single_data_storage.get) ctxt contract)
        (fun function_parameter =>
          let '(ctxt, value) := function_parameter in
          Error_monad.op_gtgtpipequestion (consume_deserialize_gas ctxt value)
            (fun ctxt => (ctxt, value))).
    
    Definition get_option
      (ctxt : (|I|).(Storage_sigs.Single_data_storage.context))
      (contract : (|I|).(Storage_sigs.Single_data_storage.key))
      : Lwt.t
        (Error_monad.tzresult
          (Raw_context.t * option (|I|).(Storage_sigs.Single_data_storage.value))) :=
      Error_monad.op_gtgteqquestion
        ((|I|).(Storage_sigs.Single_data_storage.get_option) ctxt contract)
        (fun function_parameter =>
          let '(ctxt, value_opt) := function_parameter in
          match value_opt with
          | None => Error_monad.__return (ctxt, None)
          | Some value =>
            Error_monad.op_gtgtpipequestion (consume_deserialize_gas ctxt value)
              (fun ctxt => (ctxt, value_opt))
          end).
  End Contents.
End Big_map.

Definition Delegates :=
  (Storage_functors.Make_data_set_storage
    (((Storage_functors.Make_subcontext
      (existT (fun _ => _) tt
        {|
          Storage_sigs.REGISTER.ghost :=
            (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
        |}))
      (existT _ _
        {|
          Raw_context.T.mem := Raw_context.mem;
          Raw_context.T.dir_mem := Raw_context.dir_mem;
          Raw_context.T.get := Raw_context.get;
          Raw_context.T.get_option := Raw_context.get_option;
          Raw_context.T.init := Raw_context.init;
          Raw_context.T.set := Raw_context.set;
          Raw_context.T.init_set := Raw_context.init_set;
          Raw_context.T.set_option := Raw_context.set_option;
          Raw_context.T.delete := Raw_context.delete;
          Raw_context.T.remove := Raw_context.remove;
          Raw_context.T.remove_rec := Raw_context.remove_rec;
          Raw_context.T.copy := Raw_context.copy;
          Raw_context.T.fold {_} := Raw_context.fold;
          Raw_context.T.keys := Raw_context.keys;
          Raw_context.T.fold_keys {_} := Raw_context.fold_keys;
          Raw_context.T.project := Raw_context.project;
          Raw_context.T.absolute_key := Raw_context.absolute_key;
          Raw_context.T.consume_gas := Raw_context.consume_gas;
          Raw_context.T.check_enough_gas := Raw_context.check_enough_gas;
          Raw_context.T.description := Raw_context.description
        |}))
      (let name := [ "delegates" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |})))
    (Make_index
      (existT _ _
        {|
          Storage_description.INDEX.path_length :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.path_length);
          Storage_description.INDEX.to_path :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.to_path);
          Storage_description.INDEX.of_path :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.of_path);
          Storage_description.INDEX.rpc_arg :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.rpc_arg);
          Storage_description.INDEX.encoding :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding);
          Storage_description.INDEX.compare :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.compare)
        |})).

Definition Active_delegates_with_rolls :=
  (Storage_functors.Make_data_set_storage
    (((Storage_functors.Make_subcontext
      (existT (fun _ => _) tt
        {|
          Storage_sigs.REGISTER.ghost :=
            (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
        |}))
      (existT _ _
        {|
          Raw_context.T.mem := Raw_context.mem;
          Raw_context.T.dir_mem := Raw_context.dir_mem;
          Raw_context.T.get := Raw_context.get;
          Raw_context.T.get_option := Raw_context.get_option;
          Raw_context.T.init := Raw_context.init;
          Raw_context.T.set := Raw_context.set;
          Raw_context.T.init_set := Raw_context.init_set;
          Raw_context.T.set_option := Raw_context.set_option;
          Raw_context.T.delete := Raw_context.delete;
          Raw_context.T.remove := Raw_context.remove;
          Raw_context.T.remove_rec := Raw_context.remove_rec;
          Raw_context.T.copy := Raw_context.copy;
          Raw_context.T.fold {_} := Raw_context.fold;
          Raw_context.T.keys := Raw_context.keys;
          Raw_context.T.fold_keys {_} := Raw_context.fold_keys;
          Raw_context.T.project := Raw_context.project;
          Raw_context.T.absolute_key := Raw_context.absolute_key;
          Raw_context.T.consume_gas := Raw_context.consume_gas;
          Raw_context.T.check_enough_gas := Raw_context.check_enough_gas;
          Raw_context.T.description := Raw_context.description
        |}))
      (let name := [ "active_delegates_with_rolls" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |})))
    (Make_index
      (existT _ _
        {|
          Storage_description.INDEX.path_length :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.path_length);
          Storage_description.INDEX.to_path :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.to_path);
          Storage_description.INDEX.of_path :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.of_path);
          Storage_description.INDEX.rpc_arg :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.rpc_arg);
          Storage_description.INDEX.encoding :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding);
          Storage_description.INDEX.compare :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.compare)
        |})).

Definition Delegates_with_frozen_balance_index :=
  (Storage_functors.Make_indexed_subcontext
    (((Storage_functors.Make_subcontext
      (existT (fun _ => _) tt
        {|
          Storage_sigs.REGISTER.ghost :=
            (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
        |}))
      (existT _ _
        {|
          Raw_context.T.mem := Raw_context.mem;
          Raw_context.T.dir_mem := Raw_context.dir_mem;
          Raw_context.T.get := Raw_context.get;
          Raw_context.T.get_option := Raw_context.get_option;
          Raw_context.T.init := Raw_context.init;
          Raw_context.T.set := Raw_context.set;
          Raw_context.T.init_set := Raw_context.init_set;
          Raw_context.T.set_option := Raw_context.set_option;
          Raw_context.T.delete := Raw_context.delete;
          Raw_context.T.remove := Raw_context.remove;
          Raw_context.T.remove_rec := Raw_context.remove_rec;
          Raw_context.T.copy := Raw_context.copy;
          Raw_context.T.fold {_} := Raw_context.fold;
          Raw_context.T.keys := Raw_context.keys;
          Raw_context.T.fold_keys {_} := Raw_context.fold_keys;
          Raw_context.T.project := Raw_context.project;
          Raw_context.T.absolute_key := Raw_context.absolute_key;
          Raw_context.T.consume_gas := Raw_context.consume_gas;
          Raw_context.T.check_enough_gas := Raw_context.check_enough_gas;
          Raw_context.T.description := Raw_context.description
        |}))
      (let name := [ "delegates_with_frozen_balance" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |})))
    (Make_index
      (existT _ _
        {|
          Storage_description.INDEX.path_length :=
            (|Cycle_repr.Index|).(Storage_description.INDEX.path_length);
          Storage_description.INDEX.to_path :=
            (|Cycle_repr.Index|).(Storage_description.INDEX.to_path);
          Storage_description.INDEX.of_path :=
            (|Cycle_repr.Index|).(Storage_description.INDEX.of_path);
          Storage_description.INDEX.rpc_arg :=
            (|Cycle_repr.Index|).(Storage_description.INDEX.rpc_arg);
          Storage_description.INDEX.encoding :=
            (|Cycle_repr.Index|).(Storage_description.INDEX.encoding);
          Storage_description.INDEX.compare :=
            (|Cycle_repr.Index|).(Storage_description.INDEX.compare)
        |})).

Definition Delegates_with_frozen_balance :=
  (Storage_functors.Make_data_set_storage
    (existT _ _
      {|
        Raw_context.T.mem :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.mem);
        Raw_context.T.dir_mem :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.dir_mem);
        Raw_context.T.get :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.get);
        Raw_context.T.get_option :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.get_option);
        Raw_context.T.init :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.init);
        Raw_context.T.set :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.set);
        Raw_context.T.init_set :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.init_set);
        Raw_context.T.set_option :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.set_option);
        Raw_context.T.delete :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.delete);
        Raw_context.T.remove :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.remove);
        Raw_context.T.remove_rec :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.remove_rec);
        Raw_context.T.copy :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.copy);
        Raw_context.T.fold {_} :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.fold);
        Raw_context.T.keys :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.keys);
        Raw_context.T.fold_keys {_} :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.fold_keys);
        Raw_context.T.project :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.project);
        Raw_context.T.absolute_key :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.absolute_key);
        Raw_context.T.consume_gas :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.consume_gas);
        Raw_context.T.check_enough_gas :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.check_enough_gas);
        Raw_context.T.description :=
          (|Delegates_with_frozen_balance_index.Raw_context|).(Raw_context.T.description)
      |}))
    (Make_index
      (existT _ _
        {|
          Storage_description.INDEX.path_length :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.path_length);
          Storage_description.INDEX.to_path :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.to_path);
          Storage_description.INDEX.of_path :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.of_path);
          Storage_description.INDEX.rpc_arg :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.rpc_arg);
          Storage_description.INDEX.encoding :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding);
          Storage_description.INDEX.compare :=
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.compare)
        |})).

Module Cycle.
  Definition Indexed_context :=
    (Storage_functors.Make_indexed_subcontext
      (((Storage_functors.Make_subcontext
        (existT (fun _ => _) tt
          {|
            Storage_sigs.REGISTER.ghost :=
              (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
          |}))
        (existT _ _
          {|
            Raw_context.T.mem := Raw_context.mem;
            Raw_context.T.dir_mem := Raw_context.dir_mem;
            Raw_context.T.get := Raw_context.get;
            Raw_context.T.get_option := Raw_context.get_option;
            Raw_context.T.init := Raw_context.init;
            Raw_context.T.set := Raw_context.set;
            Raw_context.T.init_set := Raw_context.init_set;
            Raw_context.T.set_option := Raw_context.set_option;
            Raw_context.T.delete := Raw_context.delete;
            Raw_context.T.remove := Raw_context.remove;
            Raw_context.T.remove_rec := Raw_context.remove_rec;
            Raw_context.T.copy := Raw_context.copy;
            Raw_context.T.fold {_} := Raw_context.fold;
            Raw_context.T.keys := Raw_context.keys;
            Raw_context.T.fold_keys {_} := Raw_context.fold_keys;
            Raw_context.T.project := Raw_context.project;
            Raw_context.T.absolute_key := Raw_context.absolute_key;
            Raw_context.T.consume_gas := Raw_context.consume_gas;
            Raw_context.T.check_enough_gas := Raw_context.check_enough_gas;
            Raw_context.T.description := Raw_context.description
          |}))
        (let name := [ "cycle" ] in
        existT (fun _ => _) tt
          {|
            Storage_sigs.NAME.name := name
          |})))
      (Make_index
        (existT _ _
          {|
            Storage_description.INDEX.path_length :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.path_length);
            Storage_description.INDEX.to_path :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.to_path);
            Storage_description.INDEX.of_path :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.of_path);
            Storage_description.INDEX.rpc_arg :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.rpc_arg);
            Storage_description.INDEX.encoding :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.encoding);
            Storage_description.INDEX.compare :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.compare)
          |})).
  
  Definition Last_roll :=
    ((Storage_functors.Make_indexed_data_storage
      (((Storage_functors.Make_subcontext
        (existT (fun _ => _) tt
          {|
            Storage_sigs.REGISTER.ghost :=
              (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
          |}))
        (existT _ _
          {|
            Raw_context.T.mem :=
              (|Indexed_context.Raw_context|).(Raw_context.T.mem);
            Raw_context.T.dir_mem :=
              (|Indexed_context.Raw_context|).(Raw_context.T.dir_mem);
            Raw_context.T.get :=
              (|Indexed_context.Raw_context|).(Raw_context.T.get);
            Raw_context.T.get_option :=
              (|Indexed_context.Raw_context|).(Raw_context.T.get_option);
            Raw_context.T.init :=
              (|Indexed_context.Raw_context|).(Raw_context.T.init);
            Raw_context.T.set :=
              (|Indexed_context.Raw_context|).(Raw_context.T.set);
            Raw_context.T.init_set :=
              (|Indexed_context.Raw_context|).(Raw_context.T.init_set);
            Raw_context.T.set_option :=
              (|Indexed_context.Raw_context|).(Raw_context.T.set_option);
            Raw_context.T.delete :=
              (|Indexed_context.Raw_context|).(Raw_context.T.delete);
            Raw_context.T.remove :=
              (|Indexed_context.Raw_context|).(Raw_context.T.remove);
            Raw_context.T.remove_rec :=
              (|Indexed_context.Raw_context|).(Raw_context.T.remove_rec);
            Raw_context.T.copy :=
              (|Indexed_context.Raw_context|).(Raw_context.T.copy);
            Raw_context.T.fold {_} :=
              (|Indexed_context.Raw_context|).(Raw_context.T.fold);
            Raw_context.T.keys :=
              (|Indexed_context.Raw_context|).(Raw_context.T.keys);
            Raw_context.T.fold_keys {_} :=
              (|Indexed_context.Raw_context|).(Raw_context.T.fold_keys);
            Raw_context.T.project :=
              (|Indexed_context.Raw_context|).(Raw_context.T.project);
            Raw_context.T.absolute_key :=
              (|Indexed_context.Raw_context|).(Raw_context.T.absolute_key);
            Raw_context.T.consume_gas :=
              (|Indexed_context.Raw_context|).(Raw_context.T.consume_gas);
            Raw_context.T.check_enough_gas :=
              (|Indexed_context.Raw_context|).(Raw_context.T.check_enough_gas);
            Raw_context.T.description :=
              (|Indexed_context.Raw_context|).(Raw_context.T.description)
          |}))
        (let name := [ "last_roll" ] in
        existT (fun _ => _) tt
          {|
            Storage_sigs.NAME.name := name
          |})))
      (existT _ [_, _]
        {|
          Storage_functors.INDEX.path_length :=
            (|Int_index|).(Storage_functors.INDEX.path_length);
          Storage_functors.INDEX.to_path :=
            (|Int_index|).(Storage_functors.INDEX.to_path);
          Storage_functors.INDEX.of_path :=
            (|Int_index|).(Storage_functors.INDEX.of_path);
          Storage_functors.INDEX.args {_} :=
            (|Int_index|).(Storage_functors.INDEX.args)
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := Roll_repr.encoding
        |}).
  
  Definition Roll_snapshot :=
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "roll_snapshot" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := (|Int|).(Storage_sigs.VALUE.encoding)
        |}).
  
  Module unrevealed_nonce.
    Record record := Build {
      nonce_hash : Nonce_hash.t;
      delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
      rewards : Tez_repr.t;
      fees : Tez_repr.t }.
    Definition with_nonce_hash nonce_hash (r : record) :=
      Build nonce_hash r.(delegate) r.(rewards) r.(fees).
    Definition with_delegate delegate (r : record) :=
      Build r.(nonce_hash) delegate r.(rewards) r.(fees).
    Definition with_rewards rewards (r : record) :=
      Build r.(nonce_hash) r.(delegate) rewards r.(fees).
    Definition with_fees fees (r : record) :=
      Build r.(nonce_hash) r.(delegate) r.(rewards) fees.
  End unrevealed_nonce.
  Definition unrevealed_nonce := unrevealed_nonce.record.
  
  Inductive nonce_status : Set :=
  | Unrevealed : unrevealed_nonce -> nonce_status
  | Revealed : Seed_repr.nonce -> nonce_status.
  
  Definition nonce_status_encoding : Data_encoding.encoding nonce_status :=
    Data_encoding.union None
      [
        Data_encoding.__case_value "Unrevealed" None (Data_encoding.Tag 0)
          (Data_encoding.tup4 Nonce_hash.encoding
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding)
            Tez_repr.encoding Tez_repr.encoding)
          (fun function_parameter =>
            match function_parameter with
            |
              Unrevealed {|
                unrevealed_nonce.nonce_hash := nonce_hash;
                  unrevealed_nonce.delegate := delegate;
                  unrevealed_nonce.rewards := rewards;
                  unrevealed_nonce.fees := fees
                  |} =>
              Some (nonce_hash, delegate, rewards, fees)
            | _ => None
            end)
          (fun function_parameter =>
            let '(nonce_hash, delegate, rewards, fees) :=
              function_parameter in
            Unrevealed
              {| unrevealed_nonce.nonce_hash := nonce_hash;
                unrevealed_nonce.delegate := delegate;
                unrevealed_nonce.rewards := rewards;
                unrevealed_nonce.fees := fees |});
        Data_encoding.__case_value "Revealed" None (Data_encoding.Tag 1)
          Seed_repr.nonce_encoding
          (fun function_parameter =>
            match function_parameter with
            | Revealed __nonce_value => Some __nonce_value
            | _ => None
            end) (fun __nonce_value => Revealed __nonce_value)
      ].
  
  Definition Nonce :=
    ((Storage_functors.Make_indexed_data_storage
      (((Storage_functors.Make_subcontext
        (existT (fun _ => _) tt
          {|
            Storage_sigs.REGISTER.ghost :=
              (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
          |}))
        (existT _ _
          {|
            Raw_context.T.mem :=
              (|Indexed_context.Raw_context|).(Raw_context.T.mem);
            Raw_context.T.dir_mem :=
              (|Indexed_context.Raw_context|).(Raw_context.T.dir_mem);
            Raw_context.T.get :=
              (|Indexed_context.Raw_context|).(Raw_context.T.get);
            Raw_context.T.get_option :=
              (|Indexed_context.Raw_context|).(Raw_context.T.get_option);
            Raw_context.T.init :=
              (|Indexed_context.Raw_context|).(Raw_context.T.init);
            Raw_context.T.set :=
              (|Indexed_context.Raw_context|).(Raw_context.T.set);
            Raw_context.T.init_set :=
              (|Indexed_context.Raw_context|).(Raw_context.T.init_set);
            Raw_context.T.set_option :=
              (|Indexed_context.Raw_context|).(Raw_context.T.set_option);
            Raw_context.T.delete :=
              (|Indexed_context.Raw_context|).(Raw_context.T.delete);
            Raw_context.T.remove :=
              (|Indexed_context.Raw_context|).(Raw_context.T.remove);
            Raw_context.T.remove_rec :=
              (|Indexed_context.Raw_context|).(Raw_context.T.remove_rec);
            Raw_context.T.copy :=
              (|Indexed_context.Raw_context|).(Raw_context.T.copy);
            Raw_context.T.fold {_} :=
              (|Indexed_context.Raw_context|).(Raw_context.T.fold);
            Raw_context.T.keys :=
              (|Indexed_context.Raw_context|).(Raw_context.T.keys);
            Raw_context.T.fold_keys {_} :=
              (|Indexed_context.Raw_context|).(Raw_context.T.fold_keys);
            Raw_context.T.project :=
              (|Indexed_context.Raw_context|).(Raw_context.T.project);
            Raw_context.T.absolute_key :=
              (|Indexed_context.Raw_context|).(Raw_context.T.absolute_key);
            Raw_context.T.consume_gas :=
              (|Indexed_context.Raw_context|).(Raw_context.T.consume_gas);
            Raw_context.T.check_enough_gas :=
              (|Indexed_context.Raw_context|).(Raw_context.T.check_enough_gas);
            Raw_context.T.description :=
              (|Indexed_context.Raw_context|).(Raw_context.T.description)
          |}))
        (let name := [ "nonces" ] in
        existT (fun _ => _) tt
          {|
            Storage_sigs.NAME.name := name
          |})))
      (Make_index
        (existT _ _
          {|
            Storage_description.INDEX.path_length :=
              (|Raw_level_repr.Index|).(Storage_description.INDEX.path_length);
            Storage_description.INDEX.to_path :=
              (|Raw_level_repr.Index|).(Storage_description.INDEX.to_path);
            Storage_description.INDEX.of_path :=
              (|Raw_level_repr.Index|).(Storage_description.INDEX.of_path);
            Storage_description.INDEX.rpc_arg :=
              (|Raw_level_repr.Index|).(Storage_description.INDEX.rpc_arg);
            Storage_description.INDEX.encoding :=
              (|Raw_level_repr.Index|).(Storage_description.INDEX.encoding);
            Storage_description.INDEX.compare :=
              (|Raw_level_repr.Index|).(Storage_description.INDEX.compare)
          |})))
      (let t := nonce_status in
      let encoding := nonce_status_encoding in
      existT _ _
        {|
          Storage_sigs.VALUE.encoding := encoding
        |}).
  
  Definition Seed :=
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "random_seed" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (let t := Seed_repr.seed in
      let encoding := Seed_repr.seed_encoding in
      existT _ _
        {|
          Storage_sigs.VALUE.encoding := encoding
        |}).
End Cycle.

Module Roll.
  Definition Raw_context :=
    ((Storage_functors.Make_subcontext
      (existT (fun _ => _) tt
        {|
          Storage_sigs.REGISTER.ghost :=
            (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
        |}))
      (existT _ _
        {|
          Raw_context.T.mem := Raw_context.mem;
          Raw_context.T.dir_mem := Raw_context.dir_mem;
          Raw_context.T.get := Raw_context.get;
          Raw_context.T.get_option := Raw_context.get_option;
          Raw_context.T.init := Raw_context.init;
          Raw_context.T.set := Raw_context.set;
          Raw_context.T.init_set := Raw_context.init_set;
          Raw_context.T.set_option := Raw_context.set_option;
          Raw_context.T.delete := Raw_context.delete;
          Raw_context.T.remove := Raw_context.remove;
          Raw_context.T.remove_rec := Raw_context.remove_rec;
          Raw_context.T.copy := Raw_context.copy;
          Raw_context.T.fold {_} := Raw_context.fold;
          Raw_context.T.keys := Raw_context.keys;
          Raw_context.T.fold_keys {_} := Raw_context.fold_keys;
          Raw_context.T.project := Raw_context.project;
          Raw_context.T.absolute_key := Raw_context.absolute_key;
          Raw_context.T.consume_gas := Raw_context.consume_gas;
          Raw_context.T.check_enough_gas := Raw_context.check_enough_gas;
          Raw_context.T.description := Raw_context.description
        |}))
      (let name := [ "rolls" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}).
  
  Definition Indexed_context :=
    (Storage_functors.Make_indexed_subcontext
      (((Storage_functors.Make_subcontext
        (existT (fun _ => _) tt
          {|
            Storage_sigs.REGISTER.ghost :=
              (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
          |}))
        (existT _ _
          {|
            Raw_context.T.mem := (|Raw_context|).(Raw_context.T.mem);
            Raw_context.T.dir_mem := (|Raw_context|).(Raw_context.T.dir_mem);
            Raw_context.T.get := (|Raw_context|).(Raw_context.T.get);
            Raw_context.T.get_option :=
              (|Raw_context|).(Raw_context.T.get_option);
            Raw_context.T.init := (|Raw_context|).(Raw_context.T.init);
            Raw_context.T.set := (|Raw_context|).(Raw_context.T.set);
            Raw_context.T.init_set := (|Raw_context|).(Raw_context.T.init_set);
            Raw_context.T.set_option :=
              (|Raw_context|).(Raw_context.T.set_option);
            Raw_context.T.delete := (|Raw_context|).(Raw_context.T.delete);
            Raw_context.T.remove := (|Raw_context|).(Raw_context.T.remove);
            Raw_context.T.remove_rec :=
              (|Raw_context|).(Raw_context.T.remove_rec);
            Raw_context.T.copy := (|Raw_context|).(Raw_context.T.copy);
            Raw_context.T.fold {_} := (|Raw_context|).(Raw_context.T.fold);
            Raw_context.T.keys := (|Raw_context|).(Raw_context.T.keys);
            Raw_context.T.fold_keys {_} :=
              (|Raw_context|).(Raw_context.T.fold_keys);
            Raw_context.T.project := (|Raw_context|).(Raw_context.T.project);
            Raw_context.T.absolute_key :=
              (|Raw_context|).(Raw_context.T.absolute_key);
            Raw_context.T.consume_gas :=
              (|Raw_context|).(Raw_context.T.consume_gas);
            Raw_context.T.check_enough_gas :=
              (|Raw_context|).(Raw_context.T.check_enough_gas);
            Raw_context.T.description :=
              (|Raw_context|).(Raw_context.T.description)
          |}))
        (let name := [ "index" ] in
        existT (fun _ => _) tt
          {|
            Storage_sigs.NAME.name := name
          |})))
      (Make_index
        (existT _ _
          {|
            Storage_description.INDEX.path_length :=
              (|Roll_repr.Index|).(Storage_description.INDEX.path_length);
            Storage_description.INDEX.to_path :=
              (|Roll_repr.Index|).(Storage_description.INDEX.to_path);
            Storage_description.INDEX.of_path :=
              (|Roll_repr.Index|).(Storage_description.INDEX.of_path);
            Storage_description.INDEX.rpc_arg :=
              (|Roll_repr.Index|).(Storage_description.INDEX.rpc_arg);
            Storage_description.INDEX.encoding :=
              (|Roll_repr.Index|).(Storage_description.INDEX.encoding);
            Storage_description.INDEX.compare :=
              (|Roll_repr.Index|).(Storage_description.INDEX.compare)
          |})).
  
  Definition Next :=
    (((Storage_functors.Make_single_data_storage
      (existT (fun _ => _) tt
        {|
          Storage_sigs.REGISTER.ghost :=
            (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
        |}))
      (existT _ _
        {|
          Raw_context.T.mem := (|Raw_context|).(Raw_context.T.mem);
          Raw_context.T.dir_mem := (|Raw_context|).(Raw_context.T.dir_mem);
          Raw_context.T.get := (|Raw_context|).(Raw_context.T.get);
          Raw_context.T.get_option := (|Raw_context|).(Raw_context.T.get_option);
          Raw_context.T.init := (|Raw_context|).(Raw_context.T.init);
          Raw_context.T.set := (|Raw_context|).(Raw_context.T.set);
          Raw_context.T.init_set := (|Raw_context|).(Raw_context.T.init_set);
          Raw_context.T.set_option := (|Raw_context|).(Raw_context.T.set_option);
          Raw_context.T.delete := (|Raw_context|).(Raw_context.T.delete);
          Raw_context.T.remove := (|Raw_context|).(Raw_context.T.remove);
          Raw_context.T.remove_rec := (|Raw_context|).(Raw_context.T.remove_rec);
          Raw_context.T.copy := (|Raw_context|).(Raw_context.T.copy);
          Raw_context.T.fold {_} := (|Raw_context|).(Raw_context.T.fold);
          Raw_context.T.keys := (|Raw_context|).(Raw_context.T.keys);
          Raw_context.T.fold_keys {_} :=
            (|Raw_context|).(Raw_context.T.fold_keys);
          Raw_context.T.project := (|Raw_context|).(Raw_context.T.project);
          Raw_context.T.absolute_key :=
            (|Raw_context|).(Raw_context.T.absolute_key);
          Raw_context.T.consume_gas :=
            (|Raw_context|).(Raw_context.T.consume_gas);
          Raw_context.T.check_enough_gas :=
            (|Raw_context|).(Raw_context.T.check_enough_gas);
          Raw_context.T.description :=
            (|Raw_context|).(Raw_context.T.description)
        |}))
      (let name := [ "next" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := Roll_repr.encoding
        |}).
  
  Definition Limbo :=
    (((Storage_functors.Make_single_data_storage
      (existT (fun _ => _) tt
        {|
          Storage_sigs.REGISTER.ghost :=
            (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
        |}))
      (existT _ _
        {|
          Raw_context.T.mem := (|Raw_context|).(Raw_context.T.mem);
          Raw_context.T.dir_mem := (|Raw_context|).(Raw_context.T.dir_mem);
          Raw_context.T.get := (|Raw_context|).(Raw_context.T.get);
          Raw_context.T.get_option := (|Raw_context|).(Raw_context.T.get_option);
          Raw_context.T.init := (|Raw_context|).(Raw_context.T.init);
          Raw_context.T.set := (|Raw_context|).(Raw_context.T.set);
          Raw_context.T.init_set := (|Raw_context|).(Raw_context.T.init_set);
          Raw_context.T.set_option := (|Raw_context|).(Raw_context.T.set_option);
          Raw_context.T.delete := (|Raw_context|).(Raw_context.T.delete);
          Raw_context.T.remove := (|Raw_context|).(Raw_context.T.remove);
          Raw_context.T.remove_rec := (|Raw_context|).(Raw_context.T.remove_rec);
          Raw_context.T.copy := (|Raw_context|).(Raw_context.T.copy);
          Raw_context.T.fold {_} := (|Raw_context|).(Raw_context.T.fold);
          Raw_context.T.keys := (|Raw_context|).(Raw_context.T.keys);
          Raw_context.T.fold_keys {_} :=
            (|Raw_context|).(Raw_context.T.fold_keys);
          Raw_context.T.project := (|Raw_context|).(Raw_context.T.project);
          Raw_context.T.absolute_key :=
            (|Raw_context|).(Raw_context.T.absolute_key);
          Raw_context.T.consume_gas :=
            (|Raw_context|).(Raw_context.T.consume_gas);
          Raw_context.T.check_enough_gas :=
            (|Raw_context|).(Raw_context.T.check_enough_gas);
          Raw_context.T.description :=
            (|Raw_context|).(Raw_context.T.description)
        |}))
      (let name := [ "limbo" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := Roll_repr.encoding
        |}).
  
  Definition Delegate_roll_list :=
    (Storage_functors.Wrap_indexed_data_storage
      (existT _ [_, _, _]
        {|
          Storage_sigs.Indexed_data_storage.mem :=
            (|Contract.Roll_list|).(Storage_sigs.Indexed_data_storage.mem);
          Storage_sigs.Indexed_data_storage.get :=
            (|Contract.Roll_list|).(Storage_sigs.Indexed_data_storage.get);
          Storage_sigs.Indexed_data_storage.get_option :=
            (|Contract.Roll_list|).(Storage_sigs.Indexed_data_storage.get_option);
          Storage_sigs.Indexed_data_storage.set :=
            (|Contract.Roll_list|).(Storage_sigs.Indexed_data_storage.set);
          Storage_sigs.Indexed_data_storage.init :=
            (|Contract.Roll_list|).(Storage_sigs.Indexed_data_storage.init);
          Storage_sigs.Indexed_data_storage.init_set :=
            (|Contract.Roll_list|).(Storage_sigs.Indexed_data_storage.init_set);
          Storage_sigs.Indexed_data_storage.set_option :=
            (|Contract.Roll_list|).(Storage_sigs.Indexed_data_storage.set_option);
          Storage_sigs.Indexed_data_storage.delete :=
            (|Contract.Roll_list|).(Storage_sigs.Indexed_data_storage.delete);
          Storage_sigs.Indexed_data_storage.remove :=
            (|Contract.Roll_list|).(Storage_sigs.Indexed_data_storage.remove);
          Storage_sigs.Indexed_data_storage.clear :=
            (|Contract.Roll_list|).(Storage_sigs.Indexed_data_storage.clear);
          Storage_sigs.Indexed_data_storage.keys :=
            (|Contract.Roll_list|).(Storage_sigs.Indexed_data_storage.keys);
          Storage_sigs.Indexed_data_storage.bindings :=
            (|Contract.Roll_list|).(Storage_sigs.Indexed_data_storage.bindings);
          Storage_sigs.Indexed_data_storage.fold {_} :=
            (|Contract.Roll_list|).(Storage_sigs.Indexed_data_storage.fold);
          Storage_sigs.Indexed_data_storage.fold_keys {_} :=
            (|Contract.Roll_list|).(Storage_sigs.Indexed_data_storage.fold_keys)
        |}))
      (* ❌ The signature name of this module could not be found *)
      first_class_module_value_of_unknown_signature.
  
  Definition Successor :=
    ((|Indexed_context|).(Storage_sigs.Indexed_raw_context.Make_map)
      (let name := [ "successor" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := Roll_repr.encoding
        |}).
  
  Definition Delegate_change :=
    (Storage_functors.Wrap_indexed_data_storage
      (existT _ [_, _, _]
        {|
          Storage_sigs.Indexed_data_storage.mem :=
            (|Contract.Change|).(Storage_sigs.Indexed_data_storage.mem);
          Storage_sigs.Indexed_data_storage.get :=
            (|Contract.Change|).(Storage_sigs.Indexed_data_storage.get);
          Storage_sigs.Indexed_data_storage.get_option :=
            (|Contract.Change|).(Storage_sigs.Indexed_data_storage.get_option);
          Storage_sigs.Indexed_data_storage.set :=
            (|Contract.Change|).(Storage_sigs.Indexed_data_storage.set);
          Storage_sigs.Indexed_data_storage.init :=
            (|Contract.Change|).(Storage_sigs.Indexed_data_storage.init);
          Storage_sigs.Indexed_data_storage.init_set :=
            (|Contract.Change|).(Storage_sigs.Indexed_data_storage.init_set);
          Storage_sigs.Indexed_data_storage.set_option :=
            (|Contract.Change|).(Storage_sigs.Indexed_data_storage.set_option);
          Storage_sigs.Indexed_data_storage.delete :=
            (|Contract.Change|).(Storage_sigs.Indexed_data_storage.delete);
          Storage_sigs.Indexed_data_storage.remove :=
            (|Contract.Change|).(Storage_sigs.Indexed_data_storage.remove);
          Storage_sigs.Indexed_data_storage.clear :=
            (|Contract.Change|).(Storage_sigs.Indexed_data_storage.clear);
          Storage_sigs.Indexed_data_storage.keys :=
            (|Contract.Change|).(Storage_sigs.Indexed_data_storage.keys);
          Storage_sigs.Indexed_data_storage.bindings :=
            (|Contract.Change|).(Storage_sigs.Indexed_data_storage.bindings);
          Storage_sigs.Indexed_data_storage.fold {_} :=
            (|Contract.Change|).(Storage_sigs.Indexed_data_storage.fold);
          Storage_sigs.Indexed_data_storage.fold_keys {_} :=
            (|Contract.Change|).(Storage_sigs.Indexed_data_storage.fold_keys)
        |}))
      (* ❌ The signature name of this module could not be found *)
      first_class_module_value_of_unknown_signature.
  
  Module Snapshoted_owner_index.
    Definition t := Cycle_repr.t * Z.
    
    Definition path_length : Z :=
      Pervasives.op_plus
        (|Cycle_repr.Index|).(Storage_description.INDEX.path_length) 1.
    
    Definition to_path
      (function_parameter :
        (|Cycle_repr.Index|).(Storage_description.INDEX.t) * Z)
      : list string -> list string :=
      let '(c, n) := function_parameter in
      fun s =>
        (|Cycle_repr.Index|).(Storage_description.INDEX.to_path) c
          (cons (Pervasives.string_of_int n) s).
    
    Definition of_path (l : list string)
      : option ((|Cycle_repr.Index|).(Storage_description.INDEX.t) * Z) :=
      match
        Misc.take (|Cycle_repr.Index|).(Storage_description.INDEX.path_length) l
        with
      | None | Some (_, [] | cons _ (cons _ _)) => None
      | Some (l1, cons l2 []) =>
        match
          (((|Cycle_repr.Index|).(Storage_description.INDEX.of_path) l1),
            (Pervasives.int_of_string_opt l2)) with
        | (None, _) | (_, None) => None
        | (Some c, Some i) => Some (c, i)
        end
      end.
    
    Definition ipath (a : Set) := (a * Cycle_repr.t) * Z.
    
    Definition left_args {A : Set}
      : Storage_description.args A Cycle_repr.cycle (A * Cycle_repr.cycle) :=
      Storage_description.One
        {| Storage_description.args.One.rpc_arg := Cycle_repr.rpc_arg;
          Storage_description.args.One.encoding := Cycle_repr.encoding;
          Storage_description.args.One.compare := Cycle_repr.compare |}.
    
    Definition right_args {A : Set}
      : Storage_description.args A (|Compare.Int|).(Compare.S.t)
        (A * (|Compare.Int|).(Compare.S.t)) :=
      Storage_description.One
        {| Storage_description.args.One.rpc_arg := RPC_arg.int;
          Storage_description.args.One.encoding := Data_encoding.int31;
          Storage_description.args.One.compare :=
            (|Compare.Int|).(Compare.S.compare) |}.
    
    Definition args {A : Set}
      : Storage_description.args A
        (Cycle_repr.cycle * (|Compare.Int|).(Compare.S.t))
        ((A * Cycle_repr.cycle) * (|Compare.Int|).(Compare.S.t)) :=
      Storage_description.Pair left_args right_args.
  End Snapshoted_owner_index.
  
  Definition Owner :=
    (((Storage_functors.Make_indexed_data_snapshotable_storage
      (((Storage_functors.Make_subcontext
        (existT (fun _ => _) tt
          {|
            Storage_sigs.REGISTER.ghost :=
              (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
          |}))
        (existT _ _
          {|
            Raw_context.T.mem := (|Raw_context|).(Raw_context.T.mem);
            Raw_context.T.dir_mem := (|Raw_context|).(Raw_context.T.dir_mem);
            Raw_context.T.get := (|Raw_context|).(Raw_context.T.get);
            Raw_context.T.get_option :=
              (|Raw_context|).(Raw_context.T.get_option);
            Raw_context.T.init := (|Raw_context|).(Raw_context.T.init);
            Raw_context.T.set := (|Raw_context|).(Raw_context.T.set);
            Raw_context.T.init_set := (|Raw_context|).(Raw_context.T.init_set);
            Raw_context.T.set_option :=
              (|Raw_context|).(Raw_context.T.set_option);
            Raw_context.T.delete := (|Raw_context|).(Raw_context.T.delete);
            Raw_context.T.remove := (|Raw_context|).(Raw_context.T.remove);
            Raw_context.T.remove_rec :=
              (|Raw_context|).(Raw_context.T.remove_rec);
            Raw_context.T.copy := (|Raw_context|).(Raw_context.T.copy);
            Raw_context.T.fold {_} := (|Raw_context|).(Raw_context.T.fold);
            Raw_context.T.keys := (|Raw_context|).(Raw_context.T.keys);
            Raw_context.T.fold_keys {_} :=
              (|Raw_context|).(Raw_context.T.fold_keys);
            Raw_context.T.project := (|Raw_context|).(Raw_context.T.project);
            Raw_context.T.absolute_key :=
              (|Raw_context|).(Raw_context.T.absolute_key);
            Raw_context.T.consume_gas :=
              (|Raw_context|).(Raw_context.T.consume_gas);
            Raw_context.T.check_enough_gas :=
              (|Raw_context|).(Raw_context.T.check_enough_gas);
            Raw_context.T.description :=
              (|Raw_context|).(Raw_context.T.description)
          |}))
        (let name := [ "owner" ] in
        existT (fun _ => _) tt
          {|
            Storage_sigs.NAME.name := name
          |})))
      (existT _ [_, _]
        {|
          Storage_functors.INDEX.path_length :=
            Snapshoted_owner_index.path_length;
          Storage_functors.INDEX.to_path := Snapshoted_owner_index.to_path;
          Storage_functors.INDEX.of_path := Snapshoted_owner_index.of_path;
          Storage_functors.INDEX.args {_} := Snapshoted_owner_index.args
        |}))
      (Make_index
        (existT _ _
          {|
            Storage_description.INDEX.path_length :=
              (|Roll_repr.Index|).(Storage_description.INDEX.path_length);
            Storage_description.INDEX.to_path :=
              (|Roll_repr.Index|).(Storage_description.INDEX.to_path);
            Storage_description.INDEX.of_path :=
              (|Roll_repr.Index|).(Storage_description.INDEX.of_path);
            Storage_description.INDEX.rpc_arg :=
              (|Roll_repr.Index|).(Storage_description.INDEX.rpc_arg);
            Storage_description.INDEX.encoding :=
              (|Roll_repr.Index|).(Storage_description.INDEX.encoding);
            Storage_description.INDEX.compare :=
              (|Roll_repr.Index|).(Storage_description.INDEX.compare)
          |})))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding :=
            (|Signature.Public_key|).(S.SPublic_key.encoding)
        |}).
  
  Definition Snapshot_for_cycle := Cycle.Roll_snapshot.
  
  Definition Last_for_snapshot := Cycle.Last_roll.
  
  Definition clear
    : (|Indexed_context|).(Storage_sigs.Indexed_raw_context.context) ->
    Lwt.t Raw_context.t :=
    (|Indexed_context|).(Storage_sigs.Indexed_raw_context.clear).
End Roll.

Module Vote.
  Definition Raw_context :=
    ((Storage_functors.Make_subcontext
      (existT (fun _ => _) tt
        {|
          Storage_sigs.REGISTER.ghost :=
            (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
        |}))
      (existT _ _
        {|
          Raw_context.T.mem := Raw_context.mem;
          Raw_context.T.dir_mem := Raw_context.dir_mem;
          Raw_context.T.get := Raw_context.get;
          Raw_context.T.get_option := Raw_context.get_option;
          Raw_context.T.init := Raw_context.init;
          Raw_context.T.set := Raw_context.set;
          Raw_context.T.init_set := Raw_context.init_set;
          Raw_context.T.set_option := Raw_context.set_option;
          Raw_context.T.delete := Raw_context.delete;
          Raw_context.T.remove := Raw_context.remove;
          Raw_context.T.remove_rec := Raw_context.remove_rec;
          Raw_context.T.copy := Raw_context.copy;
          Raw_context.T.fold {_} := Raw_context.fold;
          Raw_context.T.keys := Raw_context.keys;
          Raw_context.T.fold_keys {_} := Raw_context.fold_keys;
          Raw_context.T.project := Raw_context.project;
          Raw_context.T.absolute_key := Raw_context.absolute_key;
          Raw_context.T.consume_gas := Raw_context.consume_gas;
          Raw_context.T.check_enough_gas := Raw_context.check_enough_gas;
          Raw_context.T.description := Raw_context.description
        |}))
      (let name := [ "votes" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}).
  
  Definition Current_period_kind :=
    (((Storage_functors.Make_single_data_storage
      (existT (fun _ => _) tt
        {|
          Storage_sigs.REGISTER.ghost :=
            (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
        |}))
      (existT _ _
        {|
          Raw_context.T.mem := (|Raw_context|).(Raw_context.T.mem);
          Raw_context.T.dir_mem := (|Raw_context|).(Raw_context.T.dir_mem);
          Raw_context.T.get := (|Raw_context|).(Raw_context.T.get);
          Raw_context.T.get_option := (|Raw_context|).(Raw_context.T.get_option);
          Raw_context.T.init := (|Raw_context|).(Raw_context.T.init);
          Raw_context.T.set := (|Raw_context|).(Raw_context.T.set);
          Raw_context.T.init_set := (|Raw_context|).(Raw_context.T.init_set);
          Raw_context.T.set_option := (|Raw_context|).(Raw_context.T.set_option);
          Raw_context.T.delete := (|Raw_context|).(Raw_context.T.delete);
          Raw_context.T.remove := (|Raw_context|).(Raw_context.T.remove);
          Raw_context.T.remove_rec := (|Raw_context|).(Raw_context.T.remove_rec);
          Raw_context.T.copy := (|Raw_context|).(Raw_context.T.copy);
          Raw_context.T.fold {_} := (|Raw_context|).(Raw_context.T.fold);
          Raw_context.T.keys := (|Raw_context|).(Raw_context.T.keys);
          Raw_context.T.fold_keys {_} :=
            (|Raw_context|).(Raw_context.T.fold_keys);
          Raw_context.T.project := (|Raw_context|).(Raw_context.T.project);
          Raw_context.T.absolute_key :=
            (|Raw_context|).(Raw_context.T.absolute_key);
          Raw_context.T.consume_gas :=
            (|Raw_context|).(Raw_context.T.consume_gas);
          Raw_context.T.check_enough_gas :=
            (|Raw_context|).(Raw_context.T.check_enough_gas);
          Raw_context.T.description :=
            (|Raw_context|).(Raw_context.T.description)
        |}))
      (let name := [ "current_period_kind" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (let t := Voting_period_repr.kind in
      let encoding := Voting_period_repr.kind_encoding in
      existT _ _
        {|
          Storage_sigs.VALUE.encoding := encoding
        |}).
  
  Definition Participation_ema :=
    (((Storage_functors.Make_single_data_storage
      (existT (fun _ => _) tt
        {|
          Storage_sigs.REGISTER.ghost :=
            (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
        |}))
      (existT _ _
        {|
          Raw_context.T.mem := (|Raw_context|).(Raw_context.T.mem);
          Raw_context.T.dir_mem := (|Raw_context|).(Raw_context.T.dir_mem);
          Raw_context.T.get := (|Raw_context|).(Raw_context.T.get);
          Raw_context.T.get_option := (|Raw_context|).(Raw_context.T.get_option);
          Raw_context.T.init := (|Raw_context|).(Raw_context.T.init);
          Raw_context.T.set := (|Raw_context|).(Raw_context.T.set);
          Raw_context.T.init_set := (|Raw_context|).(Raw_context.T.init_set);
          Raw_context.T.set_option := (|Raw_context|).(Raw_context.T.set_option);
          Raw_context.T.delete := (|Raw_context|).(Raw_context.T.delete);
          Raw_context.T.remove := (|Raw_context|).(Raw_context.T.remove);
          Raw_context.T.remove_rec := (|Raw_context|).(Raw_context.T.remove_rec);
          Raw_context.T.copy := (|Raw_context|).(Raw_context.T.copy);
          Raw_context.T.fold {_} := (|Raw_context|).(Raw_context.T.fold);
          Raw_context.T.keys := (|Raw_context|).(Raw_context.T.keys);
          Raw_context.T.fold_keys {_} :=
            (|Raw_context|).(Raw_context.T.fold_keys);
          Raw_context.T.project := (|Raw_context|).(Raw_context.T.project);
          Raw_context.T.absolute_key :=
            (|Raw_context|).(Raw_context.T.absolute_key);
          Raw_context.T.consume_gas :=
            (|Raw_context|).(Raw_context.T.consume_gas);
          Raw_context.T.check_enough_gas :=
            (|Raw_context|).(Raw_context.T.check_enough_gas);
          Raw_context.T.description :=
            (|Raw_context|).(Raw_context.T.description)
        |}))
      (let name := [ "participation_ema" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := (|Int32|).(Storage_sigs.VALUE.encoding)
        |}).
  
  Definition Current_proposal :=
    (((Storage_functors.Make_single_data_storage
      (existT (fun _ => _) tt
        {|
          Storage_sigs.REGISTER.ghost :=
            (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
        |}))
      (existT _ _
        {|
          Raw_context.T.mem := (|Raw_context|).(Raw_context.T.mem);
          Raw_context.T.dir_mem := (|Raw_context|).(Raw_context.T.dir_mem);
          Raw_context.T.get := (|Raw_context|).(Raw_context.T.get);
          Raw_context.T.get_option := (|Raw_context|).(Raw_context.T.get_option);
          Raw_context.T.init := (|Raw_context|).(Raw_context.T.init);
          Raw_context.T.set := (|Raw_context|).(Raw_context.T.set);
          Raw_context.T.init_set := (|Raw_context|).(Raw_context.T.init_set);
          Raw_context.T.set_option := (|Raw_context|).(Raw_context.T.set_option);
          Raw_context.T.delete := (|Raw_context|).(Raw_context.T.delete);
          Raw_context.T.remove := (|Raw_context|).(Raw_context.T.remove);
          Raw_context.T.remove_rec := (|Raw_context|).(Raw_context.T.remove_rec);
          Raw_context.T.copy := (|Raw_context|).(Raw_context.T.copy);
          Raw_context.T.fold {_} := (|Raw_context|).(Raw_context.T.fold);
          Raw_context.T.keys := (|Raw_context|).(Raw_context.T.keys);
          Raw_context.T.fold_keys {_} :=
            (|Raw_context|).(Raw_context.T.fold_keys);
          Raw_context.T.project := (|Raw_context|).(Raw_context.T.project);
          Raw_context.T.absolute_key :=
            (|Raw_context|).(Raw_context.T.absolute_key);
          Raw_context.T.consume_gas :=
            (|Raw_context|).(Raw_context.T.consume_gas);
          Raw_context.T.check_enough_gas :=
            (|Raw_context|).(Raw_context.T.check_enough_gas);
          Raw_context.T.description :=
            (|Raw_context|).(Raw_context.T.description)
        |}))
      (let name := [ "current_proposal" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := (|Protocol_hash|).(S.HASH.encoding)
        |}).
  
  Definition Listings_size :=
    (((Storage_functors.Make_single_data_storage
      (existT (fun _ => _) tt
        {|
          Storage_sigs.REGISTER.ghost :=
            (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
        |}))
      (existT _ _
        {|
          Raw_context.T.mem := (|Raw_context|).(Raw_context.T.mem);
          Raw_context.T.dir_mem := (|Raw_context|).(Raw_context.T.dir_mem);
          Raw_context.T.get := (|Raw_context|).(Raw_context.T.get);
          Raw_context.T.get_option := (|Raw_context|).(Raw_context.T.get_option);
          Raw_context.T.init := (|Raw_context|).(Raw_context.T.init);
          Raw_context.T.set := (|Raw_context|).(Raw_context.T.set);
          Raw_context.T.init_set := (|Raw_context|).(Raw_context.T.init_set);
          Raw_context.T.set_option := (|Raw_context|).(Raw_context.T.set_option);
          Raw_context.T.delete := (|Raw_context|).(Raw_context.T.delete);
          Raw_context.T.remove := (|Raw_context|).(Raw_context.T.remove);
          Raw_context.T.remove_rec := (|Raw_context|).(Raw_context.T.remove_rec);
          Raw_context.T.copy := (|Raw_context|).(Raw_context.T.copy);
          Raw_context.T.fold {_} := (|Raw_context|).(Raw_context.T.fold);
          Raw_context.T.keys := (|Raw_context|).(Raw_context.T.keys);
          Raw_context.T.fold_keys {_} :=
            (|Raw_context|).(Raw_context.T.fold_keys);
          Raw_context.T.project := (|Raw_context|).(Raw_context.T.project);
          Raw_context.T.absolute_key :=
            (|Raw_context|).(Raw_context.T.absolute_key);
          Raw_context.T.consume_gas :=
            (|Raw_context|).(Raw_context.T.consume_gas);
          Raw_context.T.check_enough_gas :=
            (|Raw_context|).(Raw_context.T.check_enough_gas);
          Raw_context.T.description :=
            (|Raw_context|).(Raw_context.T.description)
        |}))
      (let name := [ "listings_size" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |}))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := (|Int32|).(Storage_sigs.VALUE.encoding)
        |}).
  
  Definition Listings :=
    ((Storage_functors.Make_indexed_data_storage
      (((Storage_functors.Make_subcontext
        (existT (fun _ => _) tt
          {|
            Storage_sigs.REGISTER.ghost :=
              (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
          |}))
        (existT _ _
          {|
            Raw_context.T.mem := (|Raw_context|).(Raw_context.T.mem);
            Raw_context.T.dir_mem := (|Raw_context|).(Raw_context.T.dir_mem);
            Raw_context.T.get := (|Raw_context|).(Raw_context.T.get);
            Raw_context.T.get_option :=
              (|Raw_context|).(Raw_context.T.get_option);
            Raw_context.T.init := (|Raw_context|).(Raw_context.T.init);
            Raw_context.T.set := (|Raw_context|).(Raw_context.T.set);
            Raw_context.T.init_set := (|Raw_context|).(Raw_context.T.init_set);
            Raw_context.T.set_option :=
              (|Raw_context|).(Raw_context.T.set_option);
            Raw_context.T.delete := (|Raw_context|).(Raw_context.T.delete);
            Raw_context.T.remove := (|Raw_context|).(Raw_context.T.remove);
            Raw_context.T.remove_rec :=
              (|Raw_context|).(Raw_context.T.remove_rec);
            Raw_context.T.copy := (|Raw_context|).(Raw_context.T.copy);
            Raw_context.T.fold {_} := (|Raw_context|).(Raw_context.T.fold);
            Raw_context.T.keys := (|Raw_context|).(Raw_context.T.keys);
            Raw_context.T.fold_keys {_} :=
              (|Raw_context|).(Raw_context.T.fold_keys);
            Raw_context.T.project := (|Raw_context|).(Raw_context.T.project);
            Raw_context.T.absolute_key :=
              (|Raw_context|).(Raw_context.T.absolute_key);
            Raw_context.T.consume_gas :=
              (|Raw_context|).(Raw_context.T.consume_gas);
            Raw_context.T.check_enough_gas :=
              (|Raw_context|).(Raw_context.T.check_enough_gas);
            Raw_context.T.description :=
              (|Raw_context|).(Raw_context.T.description)
          |}))
        (let name := [ "listings" ] in
        existT (fun _ => _) tt
          {|
            Storage_sigs.NAME.name := name
          |})))
      (Make_index
        (existT _ _
          {|
            Storage_description.INDEX.path_length :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.path_length);
            Storage_description.INDEX.to_path :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.to_path);
            Storage_description.INDEX.of_path :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.of_path);
            Storage_description.INDEX.rpc_arg :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.rpc_arg);
            Storage_description.INDEX.encoding :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding);
            Storage_description.INDEX.compare :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.compare)
          |})))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := (|Int32|).(Storage_sigs.VALUE.encoding)
        |}).
  
  Definition Proposals :=
    (Storage_functors.Make_data_set_storage
      (((Storage_functors.Make_subcontext
        (existT (fun _ => _) tt
          {|
            Storage_sigs.REGISTER.ghost :=
              (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
          |}))
        (existT _ _
          {|
            Raw_context.T.mem := (|Raw_context|).(Raw_context.T.mem);
            Raw_context.T.dir_mem := (|Raw_context|).(Raw_context.T.dir_mem);
            Raw_context.T.get := (|Raw_context|).(Raw_context.T.get);
            Raw_context.T.get_option :=
              (|Raw_context|).(Raw_context.T.get_option);
            Raw_context.T.init := (|Raw_context|).(Raw_context.T.init);
            Raw_context.T.set := (|Raw_context|).(Raw_context.T.set);
            Raw_context.T.init_set := (|Raw_context|).(Raw_context.T.init_set);
            Raw_context.T.set_option :=
              (|Raw_context|).(Raw_context.T.set_option);
            Raw_context.T.delete := (|Raw_context|).(Raw_context.T.delete);
            Raw_context.T.remove := (|Raw_context|).(Raw_context.T.remove);
            Raw_context.T.remove_rec :=
              (|Raw_context|).(Raw_context.T.remove_rec);
            Raw_context.T.copy := (|Raw_context|).(Raw_context.T.copy);
            Raw_context.T.fold {_} := (|Raw_context|).(Raw_context.T.fold);
            Raw_context.T.keys := (|Raw_context|).(Raw_context.T.keys);
            Raw_context.T.fold_keys {_} :=
              (|Raw_context|).(Raw_context.T.fold_keys);
            Raw_context.T.project := (|Raw_context|).(Raw_context.T.project);
            Raw_context.T.absolute_key :=
              (|Raw_context|).(Raw_context.T.absolute_key);
            Raw_context.T.consume_gas :=
              (|Raw_context|).(Raw_context.T.consume_gas);
            Raw_context.T.check_enough_gas :=
              (|Raw_context|).(Raw_context.T.check_enough_gas);
            Raw_context.T.description :=
              (|Raw_context|).(Raw_context.T.description)
          |}))
        (let name := [ "proposals" ] in
        existT (fun _ => _) tt
          {|
            Storage_sigs.NAME.name := name
          |})))
      ((Storage_functors.Pair
        (Make_index
          (existT _ _
            {|
              Storage_description.INDEX.path_length :=
                (|Protocol_hash|).(S.HASH.path_length);
              Storage_description.INDEX.to_path :=
                (|Protocol_hash|).(S.HASH.to_path);
              Storage_description.INDEX.of_path :=
                (|Protocol_hash|).(S.HASH.of_path);
              Storage_description.INDEX.rpc_arg :=
                (|Protocol_hash|).(S.HASH.rpc_arg);
              Storage_description.INDEX.encoding :=
                (|Protocol_hash|).(S.HASH.encoding);
              Storage_description.INDEX.compare :=
                (|Protocol_hash|).(S.HASH.compare)
            |})))
        (Make_index
          (existT _ _
            {|
              Storage_description.INDEX.path_length :=
                (|Signature.Public_key_hash|).(S.SPublic_key_hash.path_length);
              Storage_description.INDEX.to_path :=
                (|Signature.Public_key_hash|).(S.SPublic_key_hash.to_path);
              Storage_description.INDEX.of_path :=
                (|Signature.Public_key_hash|).(S.SPublic_key_hash.of_path);
              Storage_description.INDEX.rpc_arg :=
                (|Signature.Public_key_hash|).(S.SPublic_key_hash.rpc_arg);
              Storage_description.INDEX.encoding :=
                (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding);
              Storage_description.INDEX.compare :=
                (|Signature.Public_key_hash|).(S.SPublic_key_hash.compare)
            |}))).
  
  Definition Proposals_count :=
    ((Storage_functors.Make_indexed_data_storage
      (((Storage_functors.Make_subcontext
        (existT (fun _ => _) tt
          {|
            Storage_sigs.REGISTER.ghost :=
              (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
          |}))
        (existT _ _
          {|
            Raw_context.T.mem := (|Raw_context|).(Raw_context.T.mem);
            Raw_context.T.dir_mem := (|Raw_context|).(Raw_context.T.dir_mem);
            Raw_context.T.get := (|Raw_context|).(Raw_context.T.get);
            Raw_context.T.get_option :=
              (|Raw_context|).(Raw_context.T.get_option);
            Raw_context.T.init := (|Raw_context|).(Raw_context.T.init);
            Raw_context.T.set := (|Raw_context|).(Raw_context.T.set);
            Raw_context.T.init_set := (|Raw_context|).(Raw_context.T.init_set);
            Raw_context.T.set_option :=
              (|Raw_context|).(Raw_context.T.set_option);
            Raw_context.T.delete := (|Raw_context|).(Raw_context.T.delete);
            Raw_context.T.remove := (|Raw_context|).(Raw_context.T.remove);
            Raw_context.T.remove_rec :=
              (|Raw_context|).(Raw_context.T.remove_rec);
            Raw_context.T.copy := (|Raw_context|).(Raw_context.T.copy);
            Raw_context.T.fold {_} := (|Raw_context|).(Raw_context.T.fold);
            Raw_context.T.keys := (|Raw_context|).(Raw_context.T.keys);
            Raw_context.T.fold_keys {_} :=
              (|Raw_context|).(Raw_context.T.fold_keys);
            Raw_context.T.project := (|Raw_context|).(Raw_context.T.project);
            Raw_context.T.absolute_key :=
              (|Raw_context|).(Raw_context.T.absolute_key);
            Raw_context.T.consume_gas :=
              (|Raw_context|).(Raw_context.T.consume_gas);
            Raw_context.T.check_enough_gas :=
              (|Raw_context|).(Raw_context.T.check_enough_gas);
            Raw_context.T.description :=
              (|Raw_context|).(Raw_context.T.description)
          |}))
        (let name := [ "proposals_count" ] in
        existT (fun _ => _) tt
          {|
            Storage_sigs.NAME.name := name
          |})))
      (Make_index
        (existT _ _
          {|
            Storage_description.INDEX.path_length :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.path_length);
            Storage_description.INDEX.to_path :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.to_path);
            Storage_description.INDEX.of_path :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.of_path);
            Storage_description.INDEX.rpc_arg :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.rpc_arg);
            Storage_description.INDEX.encoding :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding);
            Storage_description.INDEX.compare :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.compare)
          |})))
      (existT _ _
        {|
          Storage_sigs.VALUE.encoding := (|Int|).(Storage_sigs.VALUE.encoding)
        |}).
  
  Definition Ballots :=
    ((Storage_functors.Make_indexed_data_storage
      (((Storage_functors.Make_subcontext
        (existT (fun _ => _) tt
          {|
            Storage_sigs.REGISTER.ghost :=
              (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
          |}))
        (existT _ _
          {|
            Raw_context.T.mem := (|Raw_context|).(Raw_context.T.mem);
            Raw_context.T.dir_mem := (|Raw_context|).(Raw_context.T.dir_mem);
            Raw_context.T.get := (|Raw_context|).(Raw_context.T.get);
            Raw_context.T.get_option :=
              (|Raw_context|).(Raw_context.T.get_option);
            Raw_context.T.init := (|Raw_context|).(Raw_context.T.init);
            Raw_context.T.set := (|Raw_context|).(Raw_context.T.set);
            Raw_context.T.init_set := (|Raw_context|).(Raw_context.T.init_set);
            Raw_context.T.set_option :=
              (|Raw_context|).(Raw_context.T.set_option);
            Raw_context.T.delete := (|Raw_context|).(Raw_context.T.delete);
            Raw_context.T.remove := (|Raw_context|).(Raw_context.T.remove);
            Raw_context.T.remove_rec :=
              (|Raw_context|).(Raw_context.T.remove_rec);
            Raw_context.T.copy := (|Raw_context|).(Raw_context.T.copy);
            Raw_context.T.fold {_} := (|Raw_context|).(Raw_context.T.fold);
            Raw_context.T.keys := (|Raw_context|).(Raw_context.T.keys);
            Raw_context.T.fold_keys {_} :=
              (|Raw_context|).(Raw_context.T.fold_keys);
            Raw_context.T.project := (|Raw_context|).(Raw_context.T.project);
            Raw_context.T.absolute_key :=
              (|Raw_context|).(Raw_context.T.absolute_key);
            Raw_context.T.consume_gas :=
              (|Raw_context|).(Raw_context.T.consume_gas);
            Raw_context.T.check_enough_gas :=
              (|Raw_context|).(Raw_context.T.check_enough_gas);
            Raw_context.T.description :=
              (|Raw_context|).(Raw_context.T.description)
          |}))
        (let name := [ "ballots" ] in
        existT (fun _ => _) tt
          {|
            Storage_sigs.NAME.name := name
          |})))
      (Make_index
        (existT _ _
          {|
            Storage_description.INDEX.path_length :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.path_length);
            Storage_description.INDEX.to_path :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.to_path);
            Storage_description.INDEX.of_path :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.of_path);
            Storage_description.INDEX.rpc_arg :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.rpc_arg);
            Storage_description.INDEX.encoding :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding);
            Storage_description.INDEX.compare :=
              (|Signature.Public_key_hash|).(S.SPublic_key_hash.compare)
          |})))
      (let t := Vote_repr.ballot in
      let encoding := Vote_repr.ballot_encoding in
      existT _ _
        {|
          Storage_sigs.VALUE.encoding := encoding
        |}).
End Vote.

Module Seed.
  Module unrevealed_nonce.
    Record record := Build {
      nonce_hash : Nonce_hash.t;
      delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
      rewards : Tez_repr.t;
      fees : Tez_repr.t }.
    Definition with_nonce_hash nonce_hash (r : record) :=
      Build nonce_hash r.(delegate) r.(rewards) r.(fees).
    Definition with_delegate delegate (r : record) :=
      Build r.(nonce_hash) delegate r.(rewards) r.(fees).
    Definition with_rewards rewards (r : record) :=
      Build r.(nonce_hash) r.(delegate) rewards r.(fees).
    Definition with_fees fees (r : record) :=
      Build r.(nonce_hash) r.(delegate) r.(rewards) fees.
  End unrevealed_nonce.
  Definition unrevealed_nonce := unrevealed_nonce.record.
  
  Inductive nonce_status : Set :=
  | Unrevealed : unrevealed_nonce -> nonce_status
  | Revealed : Seed_repr.nonce -> nonce_status.
  
  Definition Nonce :=
    (* ❌ open *)
    let context := Raw_context.t in
    let mem
      (ctxt : (|Cycle.Indexed_context|).(Storage_sigs.Indexed_raw_context.t))
      (l : Level_repr.t) : Lwt.t bool :=
      (|Cycle.Nonce|).(Storage_sigs.Indexed_data_storage.mem)
        (ctxt, (Level_repr.t.cycle l)) (Level_repr.t.level l) in
    let get
      (ctxt : (|Cycle.Indexed_context|).(Storage_sigs.Indexed_raw_context.t))
      (l : Level_repr.t)
      : Lwt.t
        (Error_monad.tzresult
          (|Cycle.Nonce|).(Storage_sigs.Indexed_data_storage.value)) :=
      (|Cycle.Nonce|).(Storage_sigs.Indexed_data_storage.get)
        (ctxt, (Level_repr.t.cycle l)) (Level_repr.t.level l) in
    let get_option
      (ctxt : (|Cycle.Indexed_context|).(Storage_sigs.Indexed_raw_context.t))
      (l : Level_repr.t)
      : Lwt.t
        (Error_monad.tzresult
          (option (|Cycle.Nonce|).(Storage_sigs.Indexed_data_storage.value))) :=
      (|Cycle.Nonce|).(Storage_sigs.Indexed_data_storage.get_option)
        (ctxt, (Level_repr.t.cycle l)) (Level_repr.t.level l) in
    let set
      (ctxt : (|Cycle.Indexed_context|).(Storage_sigs.Indexed_raw_context.t))
      (l : Level_repr.t)
      (v : (|Cycle.Nonce|).(Storage_sigs.Indexed_data_storage.value))
      : Lwt.t (Error_monad.tzresult Raw_context.t) :=
      (|Cycle.Nonce|).(Storage_sigs.Indexed_data_storage.set)
        (ctxt, (Level_repr.t.cycle l)) (Level_repr.t.level l) v in
    let init
      (ctxt : (|Cycle.Indexed_context|).(Storage_sigs.Indexed_raw_context.t))
      (l : Level_repr.t)
      (v : (|Cycle.Nonce|).(Storage_sigs.Indexed_data_storage.value))
      : Lwt.t (Error_monad.tzresult Raw_context.t) :=
      (|Cycle.Nonce|).(Storage_sigs.Indexed_data_storage.init)
        (ctxt, (Level_repr.t.cycle l)) (Level_repr.t.level l) v in
    let init_set
      (ctxt : (|Cycle.Indexed_context|).(Storage_sigs.Indexed_raw_context.t))
      (l : Level_repr.t)
      (v : (|Cycle.Nonce|).(Storage_sigs.Indexed_data_storage.value))
      : Lwt.t Raw_context.t :=
      (|Cycle.Nonce|).(Storage_sigs.Indexed_data_storage.init_set)
        (ctxt, (Level_repr.t.cycle l)) (Level_repr.t.level l) v in
    let set_option
      (ctxt : (|Cycle.Indexed_context|).(Storage_sigs.Indexed_raw_context.t))
      (l : Level_repr.t)
      (v : option (|Cycle.Nonce|).(Storage_sigs.Indexed_data_storage.value))
      : Lwt.t Raw_context.t :=
      (|Cycle.Nonce|).(Storage_sigs.Indexed_data_storage.set_option)
        (ctxt, (Level_repr.t.cycle l)) (Level_repr.t.level l) v in
    let delete
      (ctxt : (|Cycle.Indexed_context|).(Storage_sigs.Indexed_raw_context.t))
      (l : Level_repr.t) : Lwt.t (Error_monad.tzresult Raw_context.t) :=
      (|Cycle.Nonce|).(Storage_sigs.Indexed_data_storage.delete)
        (ctxt, (Level_repr.t.cycle l)) (Level_repr.t.level l) in
    let remove
      (ctxt : (|Cycle.Indexed_context|).(Storage_sigs.Indexed_raw_context.t))
      (l : Level_repr.t) : Lwt.t Raw_context.t :=
      (|Cycle.Nonce|).(Storage_sigs.Indexed_data_storage.remove)
        (ctxt, (Level_repr.t.cycle l)) (Level_repr.t.level l) in
    existT (fun _ => _) tt
      {|
        Storage_sigs.Single_data_storage.mem := mem;
        Storage_sigs.Single_data_storage.get := get;
        Storage_sigs.Single_data_storage.get_option := get_option;
        Storage_sigs.Single_data_storage.set := set;
        Storage_sigs.Single_data_storage.init := init;
        Storage_sigs.Single_data_storage.init_set := init_set;
        Storage_sigs.Single_data_storage.set_option := set_option;
        Storage_sigs.Single_data_storage.delete := delete;
        Storage_sigs.Single_data_storage.remove := remove
      |}.
  
  Definition For_cycle := Cycle.Seed.
End Seed.

Definition Commitments :=
  ((Storage_functors.Make_indexed_data_storage
    (((Storage_functors.Make_subcontext
      (existT (fun _ => _) tt
        {|
          Storage_sigs.REGISTER.ghost :=
            (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
        |}))
      (existT _ _
        {|
          Raw_context.T.mem := Raw_context.mem;
          Raw_context.T.dir_mem := Raw_context.dir_mem;
          Raw_context.T.get := Raw_context.get;
          Raw_context.T.get_option := Raw_context.get_option;
          Raw_context.T.init := Raw_context.init;
          Raw_context.T.set := Raw_context.set;
          Raw_context.T.init_set := Raw_context.init_set;
          Raw_context.T.set_option := Raw_context.set_option;
          Raw_context.T.delete := Raw_context.delete;
          Raw_context.T.remove := Raw_context.remove;
          Raw_context.T.remove_rec := Raw_context.remove_rec;
          Raw_context.T.copy := Raw_context.copy;
          Raw_context.T.fold {_} := Raw_context.fold;
          Raw_context.T.keys := Raw_context.keys;
          Raw_context.T.fold_keys {_} := Raw_context.fold_keys;
          Raw_context.T.project := Raw_context.project;
          Raw_context.T.absolute_key := Raw_context.absolute_key;
          Raw_context.T.consume_gas := Raw_context.consume_gas;
          Raw_context.T.check_enough_gas := Raw_context.check_enough_gas;
          Raw_context.T.description := Raw_context.description
        |}))
      (let name := [ "commitments" ] in
      existT (fun _ => _) tt
        {|
          Storage_sigs.NAME.name := name
        |})))
    (Make_index
      (existT _ _
        {|
          Storage_description.INDEX.path_length :=
            (|Blinded_public_key_hash.Index|).(Storage_description.INDEX.path_length);
          Storage_description.INDEX.to_path :=
            (|Blinded_public_key_hash.Index|).(Storage_description.INDEX.to_path);
          Storage_description.INDEX.of_path :=
            (|Blinded_public_key_hash.Index|).(Storage_description.INDEX.of_path);
          Storage_description.INDEX.rpc_arg :=
            (|Blinded_public_key_hash.Index|).(Storage_description.INDEX.rpc_arg);
          Storage_description.INDEX.encoding :=
            (|Blinded_public_key_hash.Index|).(Storage_description.INDEX.encoding);
          Storage_description.INDEX.compare :=
            (|Blinded_public_key_hash.Index|).(Storage_description.INDEX.compare)
        |})))
    (existT _ _
      {|
        Storage_sigs.VALUE.encoding := Tez_repr.encoding
      |}).

Module Ramp_up.
  Definition Rewards :=
    ((Storage_functors.Make_indexed_data_storage
      (((Storage_functors.Make_subcontext
        (existT (fun _ => _) tt
          {|
            Storage_sigs.REGISTER.ghost :=
              (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
          |}))
        (existT _ _
          {|
            Raw_context.T.mem := Raw_context.mem;
            Raw_context.T.dir_mem := Raw_context.dir_mem;
            Raw_context.T.get := Raw_context.get;
            Raw_context.T.get_option := Raw_context.get_option;
            Raw_context.T.init := Raw_context.init;
            Raw_context.T.set := Raw_context.set;
            Raw_context.T.init_set := Raw_context.init_set;
            Raw_context.T.set_option := Raw_context.set_option;
            Raw_context.T.delete := Raw_context.delete;
            Raw_context.T.remove := Raw_context.remove;
            Raw_context.T.remove_rec := Raw_context.remove_rec;
            Raw_context.T.copy := Raw_context.copy;
            Raw_context.T.fold {_} := Raw_context.fold;
            Raw_context.T.keys := Raw_context.keys;
            Raw_context.T.fold_keys {_} := Raw_context.fold_keys;
            Raw_context.T.project := Raw_context.project;
            Raw_context.T.absolute_key := Raw_context.absolute_key;
            Raw_context.T.consume_gas := Raw_context.consume_gas;
            Raw_context.T.check_enough_gas := Raw_context.check_enough_gas;
            Raw_context.T.description := Raw_context.description
          |}))
        (let name := [ "ramp_up"; "rewards" ] in
        existT (fun _ => _) tt
          {|
            Storage_sigs.NAME.name := name
          |})))
      (Make_index
        (existT _ _
          {|
            Storage_description.INDEX.path_length :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.path_length);
            Storage_description.INDEX.to_path :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.to_path);
            Storage_description.INDEX.of_path :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.of_path);
            Storage_description.INDEX.rpc_arg :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.rpc_arg);
            Storage_description.INDEX.encoding :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.encoding);
            Storage_description.INDEX.compare :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.compare)
          |})))
      (let t := Tez_repr.t * Tez_repr.t in
      let encoding := Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding in
      existT _ _
        {|
          Storage_sigs.VALUE.encoding := encoding
        |}).
  
  Definition Security_deposits :=
    ((Storage_functors.Make_indexed_data_storage
      (((Storage_functors.Make_subcontext
        (existT (fun _ => _) tt
          {|
            Storage_sigs.REGISTER.ghost :=
              (|Storage_functors.Registered|).(Storage_sigs.REGISTER.ghost)
          |}))
        (existT _ _
          {|
            Raw_context.T.mem := Raw_context.mem;
            Raw_context.T.dir_mem := Raw_context.dir_mem;
            Raw_context.T.get := Raw_context.get;
            Raw_context.T.get_option := Raw_context.get_option;
            Raw_context.T.init := Raw_context.init;
            Raw_context.T.set := Raw_context.set;
            Raw_context.T.init_set := Raw_context.init_set;
            Raw_context.T.set_option := Raw_context.set_option;
            Raw_context.T.delete := Raw_context.delete;
            Raw_context.T.remove := Raw_context.remove;
            Raw_context.T.remove_rec := Raw_context.remove_rec;
            Raw_context.T.copy := Raw_context.copy;
            Raw_context.T.fold {_} := Raw_context.fold;
            Raw_context.T.keys := Raw_context.keys;
            Raw_context.T.fold_keys {_} := Raw_context.fold_keys;
            Raw_context.T.project := Raw_context.project;
            Raw_context.T.absolute_key := Raw_context.absolute_key;
            Raw_context.T.consume_gas := Raw_context.consume_gas;
            Raw_context.T.check_enough_gas := Raw_context.check_enough_gas;
            Raw_context.T.description := Raw_context.description
          |}))
        (let name := [ "ramp_up"; "deposits" ] in
        existT (fun _ => _) tt
          {|
            Storage_sigs.NAME.name := name
          |})))
      (Make_index
        (existT _ _
          {|
            Storage_description.INDEX.path_length :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.path_length);
            Storage_description.INDEX.to_path :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.to_path);
            Storage_description.INDEX.of_path :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.of_path);
            Storage_description.INDEX.rpc_arg :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.rpc_arg);
            Storage_description.INDEX.encoding :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.encoding);
            Storage_description.INDEX.compare :=
              (|Cycle_repr.Index|).(Storage_description.INDEX.compare)
          |})))
      (let t := Tez_repr.t * Tez_repr.t in
      let encoding := Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding in
      existT _ _
        {|
          Storage_sigs.VALUE.encoding := encoding
        |}).
End Ramp_up.

Storage_mli

  • OCaml size: 396 lines
  • Coq size: 304 lines (-24% compared to OCaml)
storage.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Implementation - Typed storage

    This module hides the hierarchical (key x value) database under
    pre-allocated typed accessors for all persistent entities of the
    tezos context.

    This interface enforces no invariant on the contents of the
    database. Its goal is to centralize all accessors in order to have
    a complete view over the database contents and avoid key
    collisions. *)

open Storage_sigs

module Block_priority : sig
  val get : Raw_context.t -> int tzresult Lwt.t

  val set : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t

  val init : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t
end

module Roll : sig
  (** Storage from this submodule must only be accessed through the
      module `Roll`. *)

  module Owner :
    Indexed_data_snapshotable_storage
      with type key = Roll_repr.t
       and type snapshot = Cycle_repr.t * int
       and type value = Signature.Public_key.t
       and type t := Raw_context.t

  val clear : Raw_context.t -> Raw_context.t Lwt.t

  (** The next roll to be allocated. *)
  module Next :
    Single_data_storage
      with type value = Roll_repr.t
       and type t := Raw_context.t

  (** Rolls linked lists represent both account owned and free rolls.
      All rolls belongs either to the limbo list or to an owned list. *)

  (** Head of the linked list of rolls in limbo *)
  module Limbo :
    Single_data_storage
      with type value = Roll_repr.t
       and type t := Raw_context.t

  (** Rolls associated to contracts, a linked list per contract *)
  module Delegate_roll_list :
    Indexed_data_storage
      with type key = Signature.Public_key_hash.t
       and type value = Roll_repr.t
       and type t := Raw_context.t

  (** Use this to iter on a linked list of rolls *)
  module Successor :
    Indexed_data_storage
      with type key = Roll_repr.t
       and type value = Roll_repr.t
       and type t := Raw_context.t

  (** The tez of a contract that are not assigned to rolls *)
  module Delegate_change :
    Indexed_data_storage
      with type key = Signature.Public_key_hash.t
       and type value = Tez_repr.t
       and type t := Raw_context.t

  (** Index of the randomly selected roll snapshot of a given cycle. *)
  module Snapshot_for_cycle :
    Indexed_data_storage
      with type key = Cycle_repr.t
       and type value = int
       and type t := Raw_context.t

  (** Last roll in the snapshoted roll allocation of a given cycle. *)
  module Last_for_snapshot :
    Indexed_data_storage
      with type key = int
       and type value = Roll_repr.t
       and type t = Raw_context.t * Cycle_repr.t
end

module Contract : sig
  (** Storage from this submodule must only be accessed through the
      module `Contract`. *)

  module Global_counter : sig
    val get : Raw_context.t -> Z.t tzresult Lwt.t

    val set : Raw_context.t -> Z.t -> Raw_context.t tzresult Lwt.t

    val init : Raw_context.t -> Z.t -> Raw_context.t tzresult Lwt.t
  end

  (** The domain of alive contracts *)
  val fold :
    Raw_context.t ->
    init:'a ->
    f:(Contract_repr.t -> 'a -> 'a Lwt.t) ->
    'a Lwt.t

  val list : Raw_context.t -> Contract_repr.t list Lwt.t

  (** All the tez possesed by a contract, including rolls and change *)
  module Balance :
    Indexed_data_storage
      with type key = Contract_repr.t
       and type value = Tez_repr.t
       and type t := Raw_context.t

  (** Frozen balance, see 'delegate_storage.mli' for more explanation.
      Always update `Delegates_with_frozen_balance` accordingly. *)
  module Frozen_deposits :
    Indexed_data_storage
      with type key = Cycle_repr.t
       and type value = Tez_repr.t
       and type t = Raw_context.t * Contract_repr.t

  module Frozen_fees :
    Indexed_data_storage
      with type key = Cycle_repr.t
       and type value = Tez_repr.t
       and type t = Raw_context.t * Contract_repr.t

  module Frozen_rewards :
    Indexed_data_storage
      with type key = Cycle_repr.t
       and type value = Tez_repr.t
       and type t = Raw_context.t * Contract_repr.t

  (** The manager of a contract *)
  module Manager :
    Indexed_data_storage
      with type key = Contract_repr.t
       and type value = Manager_repr.t
       and type t := Raw_context.t

  (** The delegate of a contract, if any. *)
  module Delegate :
    Indexed_data_storage
      with type key = Contract_repr.t
       and type value = Signature.Public_key_hash.t
       and type t := Raw_context.t

  (** All contracts (implicit and originated) that are delegated, if any  *)
  module Delegated :
    Data_set_storage
      with type elt = Contract_repr.t
       and type t = Raw_context.t * Contract_repr.t

  module Inactive_delegate :
    Data_set_storage with type elt = Contract_repr.t and type t = Raw_context.t

  (** The cycle where the delegate should be desactivated. *)
  module Delegate_desactivation :
    Indexed_data_storage
      with type key = Contract_repr.t
       and type value = Cycle_repr.t
       and type t := Raw_context.t

  module Counter :
    Indexed_data_storage
      with type key = Contract_repr.t
       and type value = Z.t
       and type t := Raw_context.t

  module Code :
    Non_iterable_indexed_carbonated_data_storage
      with type key = Contract_repr.t
       and type value = Script_repr.lazy_expr
       and type t := Raw_context.t

  module Storage :
    Non_iterable_indexed_carbonated_data_storage
      with type key = Contract_repr.t
       and type value = Script_repr.lazy_expr
       and type t := Raw_context.t

  (** Current storage space in bytes.
      Includes code, global storage and big map elements. *)
  module Used_storage_space :
    Indexed_data_storage
      with type key = Contract_repr.t
       and type value = Z.t
       and type t := Raw_context.t

  (** Maximal space available without needing to burn new fees. *)
  module Paid_storage_space :
    Indexed_data_storage
      with type key = Contract_repr.t
       and type value = Z.t
       and type t := Raw_context.t
end

module Big_map : sig
  module Next : sig
    val incr : Raw_context.t -> (Raw_context.t * Z.t) tzresult Lwt.t

    val init : Raw_context.t -> Raw_context.t tzresult Lwt.t
  end

  (** The domain of alive big maps *)
  val fold : Raw_context.t -> init:'a -> f:(Z.t -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  val list : Raw_context.t -> Z.t list Lwt.t

  val remove_rec : Raw_context.t -> Z.t -> Raw_context.t Lwt.t

  val copy :
    Raw_context.t -> from:Z.t -> to_:Z.t -> Raw_context.t tzresult Lwt.t

  type key = Raw_context.t * Z.t

  val rpc_arg : Z.t RPC_arg.t

  module Contents :
    Non_iterable_indexed_carbonated_data_storage
      with type key = Script_expr_hash.t
       and type value = Script_repr.expr
       and type t := key

  module Total_bytes :
    Indexed_data_storage
      with type key = Z.t
       and type value = Z.t
       and type t := Raw_context.t

  module Key_type :
    Indexed_data_storage
      with type key = Z.t
       and type value = Script_repr.expr
       and type t := Raw_context.t

  module Value_type :
    Indexed_data_storage
      with type key = Z.t
       and type value = Script_repr.expr
       and type t := Raw_context.t
end

(** Set of all registered delegates. *)
module Delegates :
  Data_set_storage
    with type t := Raw_context.t
     and type elt = Signature.Public_key_hash.t

(** Set of all active delegates with rolls. *)
module Active_delegates_with_rolls :
  Data_set_storage
    with type t := Raw_context.t
     and type elt = Signature.Public_key_hash.t

(** Set of all the delegates with frozen rewards/bonds/fees for a given cycle. *)
module Delegates_with_frozen_balance :
  Data_set_storage
    with type t = Raw_context.t * Cycle_repr.t
     and type elt = Signature.Public_key_hash.t

(** Votes *)

module Vote : sig
  module Current_period_kind :
    Single_data_storage
      with type value = Voting_period_repr.kind
       and type t := Raw_context.t

  (** Participation exponential moving average, in centile of percentage *)
  module Participation_ema :
    Single_data_storage with type value = int32 and type t := Raw_context.t

  module Current_proposal :
    Single_data_storage
      with type value = Protocol_hash.t
       and type t := Raw_context.t

  (** Sum of all rolls of all delegates. *)
  module Listings_size :
    Single_data_storage with type value = int32 and type t := Raw_context.t

  (** Contains all delegates with their assigned number of rolls. *)
  module Listings :
    Indexed_data_storage
      with type key = Signature.Public_key_hash.t
       and type value = int32
       and type t := Raw_context.t

  (** Set of protocol proposal with corresponding proposer delegate *)
  module Proposals :
    Data_set_storage
      with type elt = Protocol_hash.t * Signature.Public_key_hash.t
       and type t := Raw_context.t

  (** Keeps for each delegate the number of proposed protocols *)
  module Proposals_count :
    Indexed_data_storage
      with type key = Signature.Public_key_hash.t
       and type value = int
       and type t := Raw_context.t

  (** Contains for each delegate its ballot *)
  module Ballots :
    Indexed_data_storage
      with type key = Signature.Public_key_hash.t
       and type value = Vote_repr.ballot
       and type t := Raw_context.t
end

(** Seed *)

module Seed : sig
  (** Storage from this submodule must only be accessed through the
      module `Seed`. *)

  type unrevealed_nonce = {
    nonce_hash : Nonce_hash.t;
    delegate : Signature.Public_key_hash.t;
    rewards : Tez_repr.t;
    fees : Tez_repr.t;
  }

  type nonce_status =
    | Unrevealed of unrevealed_nonce
    | Revealed of Seed_repr.nonce

  module Nonce :
    Non_iterable_indexed_data_storage
      with type key := Level_repr.t
       and type value := nonce_status
       and type t := Raw_context.t

  module For_cycle : sig
    val init :
      Raw_context.t ->
      Cycle_repr.t ->
      Seed_repr.seed ->
      Raw_context.t tzresult Lwt.t

    val get : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t

    val delete : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t
  end
end

(** Commitments *)

module Commitments :
  Indexed_data_storage
    with type key = Blinded_public_key_hash.t
     and type value = Tez_repr.t
     and type t := Raw_context.t

(** Ramp up security deposits... *)

module Ramp_up : sig
  module Rewards :
    Indexed_data_storage
      with type key = Cycle_repr.t
       and type value = Tez_repr.t * Tez_repr.t
      (* baking * endorsement *)
       and type t := Raw_context.t

  module Security_deposits :
    Indexed_data_storage
      with type key = Cycle_repr.t
       and type value = Tez_repr.t * Tez_repr.t
      (* baking * endorsement *)
       and type t := Raw_context.t
end
Storage_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Blinded_public_key_hash.
Require Tezos.Contract_repr.
Require Tezos.Cycle_repr.
Require Tezos.Level_repr.
Require Tezos.Nonce_hash.
Require Tezos.Raw_context.
Require Tezos.Roll_repr.
Require Tezos.Script_expr_hash.
Require Tezos.Script_repr.
Require Tezos.Seed_repr.
Require Tezos.Storage_sigs.
Require Tezos.Tez_repr.
Require Tezos.Vote_repr.
Require Tezos.Voting_period_repr.

Module Block_priority.
  Parameter get : Raw_context.t -> Lwt.t (Error_monad.tzresult Z).
  
  Parameter set :
    Raw_context.t -> Z -> Lwt.t (Error_monad.tzresult Raw_context.t).
  
  Parameter init :
    Raw_context.t -> Z -> Lwt.t (Error_monad.tzresult Raw_context.t).
End Block_priority.

Module Roll.
  Parameter Owner :
    {_ : unit &
      Indexed_data_snapshotable_storage.signature (Cycle_repr.t * Z) Roll_repr.t
        Raw_context.t (|Signature.Public_key|).(S.SPublic_key.t)}.
  
  Parameter clear : Raw_context.t -> Lwt.t Raw_context.t.
  
  Parameter Next :
    {_ : unit & Single_data_storage.signature Raw_context.t Roll_repr.t}.
  
  Parameter Limbo :
    {_ : unit & Single_data_storage.signature Raw_context.t Roll_repr.t}.
  
  Parameter Delegate_roll_list :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) Roll_repr.t}.
  
  Parameter Successor :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t Roll_repr.t Roll_repr.t}.
  
  Parameter Delegate_change :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) Tez_repr.t}.
  
  Parameter Snapshot_for_cycle :
    {_ : unit & Indexed_data_storage.signature Raw_context.t Cycle_repr.t Z}.
  
  Parameter Last_for_snapshot :
    {_ : unit &
      Indexed_data_storage.signature (Raw_context.t * Cycle_repr.t) Z
        Roll_repr.t}.
End Roll.

Module Contract.
  Module Global_counter.
    Parameter get : Raw_context.t -> Lwt.t (Error_monad.tzresult Z.t).
    
    Parameter set :
      Raw_context.t -> Z.t -> Lwt.t (Error_monad.tzresult Raw_context.t).
    
    Parameter init :
      Raw_context.t -> Z.t -> Lwt.t (Error_monad.tzresult Raw_context.t).
  End Global_counter.
  
  Parameter fold : forall {a : Set},
    Raw_context.t -> a -> (Contract_repr.t -> a -> Lwt.t a) -> Lwt.t a.
  
  Parameter __list_value : Raw_context.t -> Lwt.t (list Contract_repr.t).
  
  Parameter Balance :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t Contract_repr.t Tez_repr.t}.
  
  Parameter Frozen_deposits :
    {_ : unit &
      Indexed_data_storage.signature (Raw_context.t * Contract_repr.t)
        Cycle_repr.t Tez_repr.t}.
  
  Parameter Frozen_fees :
    {_ : unit &
      Indexed_data_storage.signature (Raw_context.t * Contract_repr.t)
        Cycle_repr.t Tez_repr.t}.
  
  Parameter Frozen_rewards :
    {_ : unit &
      Indexed_data_storage.signature (Raw_context.t * Contract_repr.t)
        Cycle_repr.t Tez_repr.t}.
  
  Parameter Manager :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t Contract_repr.t
        (|Manager_repr|).(Storage_sigs.VALUE.t)}.
  
  Parameter Delegate :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t Contract_repr.t
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)}.
  
  Parameter Delegated :
    {_ : unit &
      Data_set_storage.signature (Raw_context.t * Contract_repr.t)
        Contract_repr.t}.
  
  Parameter Inactive_delegate :
    {_ : unit & Data_set_storage.signature Raw_context.t Contract_repr.t}.
  
  Parameter Delegate_desactivation :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t Contract_repr.t Cycle_repr.t}.
  
  Parameter Counter :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t Contract_repr.t Z.t}.
  
  Parameter Code :
    {_ : unit &
      Non_iterable_indexed_carbonated_data_storage.signature Raw_context.t
        Contract_repr.t Script_repr.lazy_expr}.
  
  Parameter Storage :
    {_ : unit &
      Non_iterable_indexed_carbonated_data_storage.signature Raw_context.t
        Contract_repr.t Script_repr.lazy_expr}.
  
  Parameter Used_storage_space :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t Contract_repr.t Z.t}.
  
  Parameter Paid_storage_space :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t Contract_repr.t Z.t}.
End Contract.

Module Big_map.
  Module Next.
    Parameter incr :
      Raw_context.t -> Lwt.t (Error_monad.tzresult (Raw_context.t * Z.t)).
    
    Parameter init :
      Raw_context.t -> Lwt.t (Error_monad.tzresult Raw_context.t).
  End Next.
  
  Parameter fold : forall {a : Set},
    Raw_context.t -> a -> (Z.t -> a -> Lwt.t a) -> Lwt.t a.
  
  Parameter __list_value : Raw_context.t -> Lwt.t (list Z.t).
  
  Parameter remove_rec : Raw_context.t -> Z.t -> Lwt.t Raw_context.t.
  
  Parameter copy :
    Raw_context.t -> Z.t -> Z.t -> Lwt.t (Error_monad.tzresult Raw_context.t).
  
  Definition key := Raw_context.t * Z.t.
  
  Parameter rpc_arg : RPC_arg.t Z.t.
  
  Parameter Contents :
    {_ : unit &
      Non_iterable_indexed_carbonated_data_storage.signature key
        Script_expr_hash.t Script_repr.expr}.
  
  Parameter Total_bytes :
    {_ : unit & Indexed_data_storage.signature Raw_context.t Z.t Z.t}.
  
  Parameter Key_type :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t Z.t Script_repr.expr}.
  
  Parameter Value_type :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t Z.t Script_repr.expr}.
End Big_map.

Parameter Delegates :
  {_ : unit &
    Data_set_storage.signature Raw_context.t
      (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)}.

Parameter Active_delegates_with_rolls :
  {_ : unit &
    Data_set_storage.signature Raw_context.t
      (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)}.

Parameter Delegates_with_frozen_balance :
  {_ : unit &
    Data_set_storage.signature (Raw_context.t * Cycle_repr.t)
      (|Signature.Public_key_hash|).(S.SPublic_key_hash.t)}.

Module Vote.
  Parameter Current_period_kind :
    {_ : unit &
      Single_data_storage.signature Raw_context.t Voting_period_repr.kind}.
  
  Parameter Participation_ema :
    {_ : unit & Single_data_storage.signature Raw_context.t int32}.
  
  Parameter Current_proposal :
    {_ : unit &
      Single_data_storage.signature Raw_context.t (|Protocol_hash|).(S.HASH.t)}.
  
  Parameter Listings_size :
    {_ : unit & Single_data_storage.signature Raw_context.t int32}.
  
  Parameter Listings :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) int32}.
  
  Parameter Proposals :
    {_ : unit &
      Data_set_storage.signature Raw_context.t
        ((|Protocol_hash|).(S.HASH.t) *
          (|Signature.Public_key_hash|).(S.SPublic_key_hash.t))}.
  
  Parameter Proposals_count :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) Z}.
  
  Parameter Ballots :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) Vote_repr.ballot}.
End Vote.

Module Seed.
  Module unrevealed_nonce.
    Record record := Build {
      nonce_hash : Nonce_hash.t;
      delegate : (|Signature.Public_key_hash|).(S.SPublic_key_hash.t);
      rewards : Tez_repr.t;
      fees : Tez_repr.t }.
    Definition with_nonce_hash nonce_hash (r : record) :=
      Build nonce_hash r.(delegate) r.(rewards) r.(fees).
    Definition with_delegate delegate (r : record) :=
      Build r.(nonce_hash) delegate r.(rewards) r.(fees).
    Definition with_rewards rewards (r : record) :=
      Build r.(nonce_hash) r.(delegate) rewards r.(fees).
    Definition with_fees fees (r : record) :=
      Build r.(nonce_hash) r.(delegate) r.(rewards) fees.
  End unrevealed_nonce.
  Definition unrevealed_nonce := unrevealed_nonce.record.
  
  Inductive nonce_status : Set :=
  | Unrevealed : unrevealed_nonce -> nonce_status
  | Revealed : Seed_repr.nonce -> nonce_status.
  
  Parameter Nonce :
    {_ : unit &
      Non_iterable_indexed_data_storage.signature Raw_context.t Level_repr.t
        nonce_status}.
  
  Module For_cycle.
    Parameter init :
      Raw_context.t -> Cycle_repr.t -> Seed_repr.seed ->
      Lwt.t (Error_monad.tzresult Raw_context.t).
    
    Parameter get :
      Raw_context.t -> Cycle_repr.t ->
      Lwt.t (Error_monad.tzresult Seed_repr.seed).
    
    Parameter delete :
      Raw_context.t -> Cycle_repr.t ->
      Lwt.t (Error_monad.tzresult Raw_context.t).
  End For_cycle.
End Seed.

Parameter Commitments :
  {_ : unit &
    Indexed_data_storage.signature Raw_context.t Blinded_public_key_hash.t
      Tez_repr.t}.

Module Ramp_up.
  Parameter Rewards :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t Cycle_repr.t
        (Tez_repr.t * Tez_repr.t)}.
  
  Parameter Security_deposits :
    {_ : unit &
      Indexed_data_storage.signature Raw_context.t Cycle_repr.t
        (Tez_repr.t * Tez_repr.t)}.
End Ramp_up.

Storage_description

  • OCaml size: 344 lines
  • Coq size: 665 lines (+93% compared to OCaml)
storage_description.ml 11 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module StringMap = Map.Make (String)

type 'key description =
  | Empty : 'key description
  | Value : {
      get : 'key -> 'a option tzresult Lwt.t;
      encoding : 'a Data_encoding.t;
    }
      -> 'key description
  | NamedDir : 'key t StringMap.t -> 'key description
  | IndexedDir : {
      arg : 'a RPC_arg.t;
      arg_encoding : 'a Data_encoding.t;
      list : 'key -> 'a list tzresult Lwt.t;
      subdir : ('key * 'a) t;
    }
      -> 'key description

and 'key t = 'key description ref

let rec register_named_subcontext : type r. r t -> string list -> r t =
 fun dir names ->
  match (!dir, names) with
  | (_, []) ->
      dir
  | (Value _, _) ->
      invalid_arg ""
  | (IndexedDir _, _) ->
      invalid_arg ""
  | (Empty, name :: names) ->
      let subdir = ref Empty in
      dir := NamedDir (StringMap.singleton name subdir) ;
      register_named_subcontext subdir names
  | (NamedDir map, name :: names) ->
      let subdir =
        match StringMap.find_opt name map with
        | Some subdir ->
            subdir
        | None ->
            let subdir = ref Empty in
            dir := NamedDir (StringMap.add name subdir map) ;
            subdir
      in
      register_named_subcontext subdir names

type (_, _, _) args =
  | One : {
      rpc_arg : 'a RPC_arg.t;
      encoding : 'a Data_encoding.t;
      compare : 'a -> 'a -> int;
    }
      -> ('key, 'a, 'key * 'a) args
  | Pair :
      ('key, 'a, 'inter_key) args * ('inter_key, 'b, 'sub_key) args
      -> ('key, 'a * 'b, 'sub_key) args

let rec unpack : type a b c. (a, b, c) args -> c -> a * b =
  fun v x ->
  match[@coq_match_gadt] v with
  | One _ -> x
  | Pair (l, r) ->
      let unpack_l = unpack l in
      let unpack_r = unpack r in
      let (c, d) = unpack_r x in
      let (b, a) = unpack_l c in
      (b, (a, d))

let rec pack : type a b c. (a, b, c) args -> a -> b -> c =
  fun v x y ->
  match[@coq_match_gadt] v, y with
  | One _, _ -> (x, y)
  | Pair (l, r), (y : _ * _) ->
      let pack_l = pack l in
      let pack_r = pack r in
      let (a, d) = y in
      let c = pack_l x a in
      pack_r c d

let rec compare : type a b c. (a, b, c) args -> b -> b -> int =
  function[@coq_match_gadt]
  | One {compare = compare'; _} ->
      compare'
  | Pair (l, r) -> (
      let compare_l = compare l in
      let compare_r = compare r in
      fun (a1, b1) (a2, b2) ->
        match compare_l a1 a2 with 0 -> compare_r b1 b2 | x -> x )

let destutter equal l =
  match l with
  | [] ->
      []
  | (i, _) :: l ->
      let rec loop acc i = function
        | [] ->
            acc
        | (j, _) :: l ->
            if equal i j then loop acc i l else loop (j :: acc) j l
      in
      loop [i] i l

let rec register_indexed_subcontext :
    type r a b.
    r t -> list:(r -> a list tzresult Lwt.t) -> (r, a, b) args -> b t =
 fun dir ~list path ->
  match[@coq_match_gadt] path, list with
  | Pair (left, right), (list : _ -> (_ * _) list tzresult Lwt.t) ->
      let compare_left = compare left in
      let equal_left x y = Compare.Int.(compare_left x y = 0) in
      let list_left r = list r >>=? fun l -> return (destutter equal_left l) in
      let list_right r =
        let (a, k) = unpack left r in
        list a
        >>=? fun l ->
        return (List.map snd (List.filter (fun (x, _) -> equal_left x k) l))
      in
      register_indexed_subcontext
        (register_indexed_subcontext dir ~list:list_left left)
        ~list:list_right
        right
  | One {rpc_arg = arg; encoding = arg_encoding; _}, _ -> (
    match !dir with
    | Value _ ->
        invalid_arg ""
    | NamedDir _ ->
        invalid_arg ""
    | Empty ->
        let subdir = ref Empty in
        dir := IndexedDir {arg; arg_encoding; list; subdir} ;
        subdir
    | IndexedDir {arg = inner_arg; subdir; _} -> (
      match RPC_arg.eq arg inner_arg with
      | None ->
          invalid_arg ""
      | Some RPC_arg.Eq ->
          subdir ) )

let register_value :
    type a b.
    a t -> get:(a -> b option tzresult Lwt.t) -> b Data_encoding.t -> unit =
 fun dir ~get encoding ->
  match !dir with Empty -> dir := Value {get; encoding} | _ -> invalid_arg ""

let create () = ref Empty

let rec pp : type a. Format.formatter -> a t -> unit =
 fun ppf dir ->
  match !dir with
  | Empty ->
      Format.fprintf ppf "EMPTY"
  | Value _e ->
      Format.fprintf ppf "Value"
  | NamedDir map ->
      Format.fprintf
        ppf
        "@[<v>%a@]"
        (Format.pp_print_list (pp_item[@coq_implicit "(a := unit)"]))
        (StringMap.bindings map)
  | IndexedDir {arg; subdir; _} ->
      let name = Format.asprintf "<%s>" (RPC_arg.descr arg).name in
      (pp_item[@coq_implicit "(a := unit)"]) ppf (name, subdir)

and pp_item : type a. Format.formatter -> string * a t -> unit =
 fun ppf (name, dir) -> Format.fprintf ppf "@[<v 2>%s@ %a@]" name (pp[@coq_implicit "(a := unit)"]) dir

module type INDEX = sig
  type t

  val path_length : int

  val to_path : t -> string list -> string list

  val of_path : string list -> t option

  val rpc_arg : t RPC_arg.t

  val encoding : t Data_encoding.t

  val compare : t -> t -> int
end

type _ handler =
  | Handler : {
      encoding : 'a Data_encoding.t;
      get : 'key -> int -> 'a tzresult Lwt.t;
    } -> 'key handler

type _ opt_handler =
  | Opt_handler : {
      encoding : 'a Data_encoding.t;
      get : 'key -> int -> 'a option tzresult Lwt.t;
    } -> 'key opt_handler

let rec combine_object = function[@coq_match_gadt]
  | [] ->
      Handler
        {encoding = Data_encoding.unit; get = (fun _ _ -> return_unit)}
        [@coq_implicit "(key := A)"]
  | (name, Opt_handler handler) :: fields ->
      begin match[@coq_match_gadt] combine_object fields with
      | Handler handlers ->
        Handler
          {
            encoding =
              Data_encoding.merge_objs
                Data_encoding.(obj1 (opt name (dynamic_size handler.encoding)))
                handlers.encoding;
            get =
              (fun k i ->
                handler.get k i
                >>=? fun v1 -> handlers.get k i >>=? fun v2 -> return (v1, v2));
          }
      end

type query = {depth : int}

let depth_query =
  let open RPC_query in
  query (fun depth -> {depth})
  |+ field "depth" RPC_arg.int 0 (fun t -> t.depth)
  |> seal

let build_directory : type key. key t -> key RPC_directory.t =
 fun dir ->
  let rpc_dir = ref (RPC_directory.empty : key RPC_directory.t) in
  let register : type ikey. (key, ikey) RPC_path.t -> ikey opt_handler -> unit
      =
   fun path -> function[@coq_match_gadt] (Opt_handler {encoding; get}) ->
    let service =
      RPC_service.get_service ~query:depth_query ~output:encoding path
    in
    rpc_dir :=
      RPC_directory.register !rpc_dir service (fun k q () ->
          get k (q.depth + 1)
          >>=? function None -> raise Not_found | Some x -> return x)
  in
  let rec build_handler :
      type ikey. ikey t -> (key, ikey) RPC_path.t -> ikey opt_handler =
   fun dir path ->
    match[@coq_match_gadt] !dir with
    | Empty ->
        Opt_handler
          {encoding = Data_encoding.unit; get = (fun _ _ -> return_none)}
          [@coq_implicit "(key := ikey)"]
    | Value {get; encoding} ->
        let handler =
          Opt_handler
            {
              encoding;
              get =
                (fun k i -> if Compare.Int.(i < 0) then return_none else get k);
            }
        in
        register path handler ; handler
    | NamedDir map ->
        let fields = StringMap.bindings map in
        let fields =
          List.map
            (fun (name, dir) ->
              (name, build_handler dir RPC_path.(path / name)))
            fields
        in
        let (Handler handler) = combine_object fields in
        let handler =
          Opt_handler
            {
              encoding = handler.encoding;
              get =
                (fun k i ->
                  if Compare.Int.(i < 0) then return_none
                  else handler.get k (i - 1) >>=? fun v -> return_some v);
            }
        in
        register path handler ; handler
    | IndexedDir {arg; arg_encoding; list; subdir} ->
        begin match[@coq_match_gadt] build_handler subdir RPC_path.(path /: arg) with
        | Opt_handler handler ->
          let encoding =
            let open Data_encoding in
            union
              [ case
                  (Tag 0)
                  ~title:"Leaf"
                  (dynamic_size arg_encoding)
                  (function (key, None) -> Some key | _ -> None)
                  (fun key -> (key, None));
                case
                  (Tag 1)
                  ~title:"Dir"
                  (tup2
                    (dynamic_size arg_encoding)
                    (dynamic_size handler.encoding))
                  (function (key, Some value) -> Some (key, value) | _ -> None)
                  (fun (key, value) -> (key, Some value)) ]
          in
          let get k i =
            if Compare.Int.(i < 0) then return_none
            else if Compare.Int.(i = 0) then return_some []
            else
              list k
              >>=? fun keys ->
              map_s
                (fun key ->
                  if Compare.Int.(i = 1) then return (key, None)
                  else
                    handler.get (k, key) (i - 1)
                    >>=? fun value -> return (key, value))
                keys
              >>=? fun values -> return_some values
          in
          let handler =
            Opt_handler
              {encoding = Data_encoding.(list (dynamic_size encoding)); get}
          in
          register path handler ; handler
        end
  in
  ignore (build_handler dir RPC_path.open_root : key opt_handler) ;
  !rpc_dir
Storage_description.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Definition StringMap :=
  Map.Make
    (existT _ _
      {|
        Compare.COMPARABLE.compare := String.compare
      |}).

Module description.
  Module Value.
    Record record {get encoding : Set} := {
      get : get;
      encoding : encoding }.
    Arguments record : clear implicits.
  End Value.
  Definition Value_skeleton := Value.record.
  
  Module IndexedDir.
    Record record {arg arg_encoding list subdir : Set} := {
      arg : arg;
      arg_encoding : arg_encoding;
      list : list;
      subdir : subdir }.
    Arguments record : clear implicits.
  End IndexedDir.
  Definition IndexedDir_skeleton := IndexedDir.record.
End description.

Reserved Notation "'description.Value".
Reserved Notation "'description.IndexedDir".
Reserved Notation "'description".
Reserved Notation "'t".

Inductive description_gadt : Set :=
| Empty : description_gadt
| Value : forall {a key : Set}, 'description.Value a key -> description_gadt
| NamedDir : forall {key : Set},
  (|StringMap|).(S.MAP.t) ('t key) -> description_gadt
| IndexedDir : forall {a key : Set},
  'description.IndexedDir a key -> description_gadt

where "'description" := (fun (_ : Set) => description_gadt)
and "'t" := (fun (t_key : Set) => Pervasives.ref ('description t_key))
and "'description.Value" := (fun (t_a t_key : Set) =>
  description.Value_skeleton
    (t_key -> Lwt.t (Error_monad.tzresult (option t_a))) (Data_encoding.t t_a))
and "'description.IndexedDir" := (fun (t_a t_key : Set) =>
  description.IndexedDir_skeleton (RPC_arg.t t_a) (Data_encoding.t t_a)
    (t_key -> Lwt.t (Error_monad.tzresult (list t_a))) ('t (t_key * t_a))).

Module ConstructorRecordNotations_description_gadt.
  Module description.
    Definition Value := 'description.Value.
    Definition IndexedDir := 'description.IndexedDir.
  End description.
End ConstructorRecordNotations_description_gadt.
Import ConstructorRecordNotations_description_gadt.

Definition description := 'description.
Definition t := 't.

Fixpoint register_named_subcontext {r : Set} (dir : t r) (names : list string)
  {struct dir} : t r :=
  match ((Pervasives.op_exclamation dir), names) with
  | (_, []) => dir
  | (Value _, _) => Pervasives.invalid_arg ""
  | (IndexedDir _, _) => Pervasives.invalid_arg ""
  | (Empty, cons name names) =>
    let subdir := Pervasives.__ref_value Empty in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    (* ❌ instruction_sequence ";" *)
    register_named_subcontext subdir names
  | (NamedDir map, cons name names) =>
    let subdir :=
      match (|StringMap|).(S.MAP.find_opt) name map with
      | Some subdir => subdir
      | None =>
        let subdir := Pervasives.__ref_value Empty in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        (* ❌ instruction_sequence ";" *)
        subdir
      end in
    register_named_subcontext subdir names
  end.

Module args.
  Module One.
    Record record {rpc_arg encoding compare : Set} := {
      rpc_arg : rpc_arg;
      encoding : encoding;
      compare : compare }.
    Arguments record : clear implicits.
  End One.
  Definition One_skeleton := One.record.
End args.

Reserved Notation "'args.One".
Reserved Notation "'args".

Inductive args_gadt : Set :=
| One : forall {a : Set}, 'args.One a -> args_gadt
| Pair : args_gadt -> args_gadt -> args_gadt

where "'args" := (fun (_ _ _ : Set) => args_gadt)
and "'args.One" := (fun (t_a : Set) =>
  args.One_skeleton (RPC_arg.t t_a) (Data_encoding.t t_a) (t_a -> t_a -> Z)).

Module ConstructorRecordNotations_args_gadt.
  Module args.
    Definition One := 'args.One.
  End args.
End ConstructorRecordNotations_args_gadt.
Import ConstructorRecordNotations_args_gadt.

Definition args := 'args.

Fixpoint unpack {a b c : Set} (v : args a b c) (x : c) {struct v} : a * b :=
  match v with
  | One _ => obj_magic (a * b) x
  | Pair l r =>
    let 'existT _ [__0, __1, __Pair_'inter_key] [l, r] :=
      obj_magic_exists
        (fun '[__0, __1, __Pair_'inter_key] =>
          [(args a __0 __Pair_'inter_key) ** (args __Pair_'inter_key __1 c)])
        [l, r] in
    obj_magic (a * b)
      (let unpack_l := unpack l in
      let unpack_r := unpack r in
      let '(c, d) := unpack_r x in
      let '(b, a) := unpack_l c in
      (b, (a, d)))
  end.

Fixpoint pack {a b c : Set} (v : args a b c) (x : a) (y : b) {struct v} : c :=
  match (v, y) with
  | (One _, _) => obj_magic c (x, y)
  | (Pair l r, _ as y) =>
    let 'existT _ [__0, __1, __Pair_'inter_key] [l, r, y] :=
      obj_magic_exists
        (fun '[__0, __1, __Pair_'inter_key] =>
          [(args a __0 __Pair_'inter_key) ** (args __Pair_'inter_key __1 c) **
            (__0 * __1)]) [l, r, y] in
    obj_magic c
      (let pack_l := pack l in
      let pack_r := pack r in
      let '(a, d) := y in
      let c := pack_l x a in
      pack_r c d)
  end.

Fixpoint compare {a b c : Set} (function_parameter : args a b c)
  {struct function_parameter} : b -> b -> Z :=
  match function_parameter with
  | One {| args.One.compare := compare' |} =>
    let 'existT _ tt compare' :=
      obj_magic_exists (fun _ => (b -> b -> Z)) compare' in
    obj_magic (b -> b -> Z) compare'
  | Pair l r =>
    let 'existT _ [__0, __1, __Pair_'inter_key] [l, r] :=
      obj_magic_exists
        (fun '[__0, __1, __Pair_'inter_key] =>
          [(args a __0 __Pair_'inter_key) ** (args __Pair_'inter_key __1 c)])
        [l, r] in
    obj_magic (b -> b -> Z)
      (let compare_l := compare l in
      let compare_r := compare r in
      fun function_parameter =>
        let '(a1, b1) := function_parameter in
        fun function_parameter =>
          let '(a2, b2) := function_parameter in
          match compare_l a1 a2 with
          | 0 => compare_r b1 b2
          | x => x
          end)
  end.

Definition destutter {A B : Set} (equal : A -> A -> bool) (l : list (A * B))
  : list A :=
  match l with
  | [] => []
  | cons (i, _) l =>
    let fix loop {C : Set}
      (acc : list A) (i : A) (function_parameter : list (A * C)) {struct acc}
      : list A :=
      match function_parameter with
      | [] => acc
      | cons (j, _) l =>
        if equal i j then
          loop acc i l
        else
          loop (cons j acc) j l
      end in
    loop [ i ] i l
  end.

Fixpoint register_indexed_subcontext {a b r : Set}
  (dir : t r) (__list_value : r -> Lwt.t (Error_monad.tzresult (list a)))
  (path : args r a b) {struct dir} : t b :=
  match (path, __list_value) with
  | (Pair __left __right, _ as __list_value) =>
    let 'existT _ [__0, __1, __Pair_'inter_key] [__left, __right, __list_value]
      :=
      obj_magic_exists
        (fun '[__0, __1, __Pair_'inter_key] =>
          [(args r __0 __Pair_'inter_key) ** (args __Pair_'inter_key __1 b) **
            (r -> Lwt.t (Error_monad.tzresult (list (__0 * __1))))])
        [__left, __right, __list_value] in
    obj_magic (t b)
      (let compare_left := compare __left in
      let equal_left (x : __0) (y : __0) : bool :=
        (|Compare.Int|).(Compare.S.op_eq) (compare_left x y) 0 in
      let list_left (r : r) : Lwt.t (Error_monad.tzresult (list __0)) :=
        Error_monad.op_gtgteqquestion (__list_value r)
          (fun l => Error_monad.__return (destutter equal_left l)) in
      let list_right (r : __Pair_'inter_key)
        : Lwt.t (Error_monad.tzresult (list __1)) :=
        let '(a, k) := unpack __left r in
        Error_monad.op_gtgteqquestion (__list_value a)
          (fun l =>
            Error_monad.__return
              (List.map Pervasives.snd
                (List.filter
                  (fun function_parameter =>
                    let '(x, _) := function_parameter in
                    equal_left x k) l))) in
      register_indexed_subcontext
        (register_indexed_subcontext dir list_left __left) list_right __right)
  | (One {| args.One.rpc_arg := arg; args.One.encoding := arg_encoding |}, _) =>
    let 'existT _ tt [arg, arg_encoding] :=
      obj_magic_exists (fun _ => [(RPC_arg.t a) ** (Data_encoding.t a)])
        [arg, arg_encoding] in
    obj_magic (t b)
      match Pervasives.op_exclamation dir with
      | Value _ => Pervasives.invalid_arg ""
      | NamedDir _ => Pervasives.invalid_arg ""
      | Empty =>
        let subdir := Pervasives.__ref_value Empty in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        (* ❌ instruction_sequence ";" *)
        subdir
      |
        IndexedDir {|
          description.IndexedDir.arg := inner_arg;
            description.IndexedDir.subdir := subdir
            |} =>
        match RPC_arg.__eq_value arg inner_arg with
        | None => Pervasives.invalid_arg ""
        | Some RPC_arg.Eq => subdir
        end
      end
  end.

Definition register_value {a b : Set}
  (dir : t a) (get : a -> Lwt.t (Error_monad.tzresult (option b)))
  (encoding : Data_encoding.t b) : unit :=
  match Pervasives.op_exclamation dir with
  | Empty =>
    Pervasives.op_coloneq dir
      (Value
        {| description.Value.get := get; description.Value.encoding := encoding
          |})
  | _ => Pervasives.invalid_arg ""
  end.

Definition create {A : Set} (function_parameter : unit)
  : Pervasives.ref (description A) :=
  let '_ := function_parameter in
  Pervasives.__ref_value Empty.

Fixpoint pp {a : Set} (ppf : Format.formatter) (dir : t a) {struct ppf}
  : unit :=
  match Pervasives.op_exclamation dir with
  | Empty =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "EMPTY"
          CamlinternalFormatBasics.End_of_format) "EMPTY")
  | Value _e =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Value"
          CamlinternalFormatBasics.End_of_format) "Value")
  | NamedDir map =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v>"
                CamlinternalFormatBasics.End_of_format) "<v>"))
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              CamlinternalFormatBasics.End_of_format))) "@[<v>%a@]")
      (Format.pp_print_list None (pp_item (a := unit)))
      ((|StringMap|).(S.MAP.bindings) map)
  |
    IndexedDir {|
      description.IndexedDir.arg := arg;
        description.IndexedDir.subdir := subdir
        |} =>
    let name :=
      Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "<" % char
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ">" % char
                CamlinternalFormatBasics.End_of_format))) "<%s>")
        (RPC_arg.descr.name (RPC_arg.__descr_value arg)) in
    (pp_item (a := unit)) ppf (name, subdir)
  end

with pp_item {a : Set}
  (ppf : Format.formatter) (function_parameter : string * t a) {struct ppf}
  : unit :=
  let '(name, dir) := function_parameter in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "<v 2>"
              CamlinternalFormatBasics.End_of_format) "<v 2>"))
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " 1 0)
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Close_box
                CamlinternalFormatBasics.End_of_format))))) "@[<v 2>%s@ %a@]")
    name (pp (a := unit)) dir.

Module INDEX.
  Record signature {t : Set} := {
    t := t;
    path_length : Z;
    to_path : t -> list string -> list string;
    of_path : list string -> option t;
    rpc_arg : RPC_arg.t t;
    encoding : Data_encoding.t t;
    compare : t -> t -> Z;
  }.
  Arguments signature : clear implicits.
End INDEX.

Module handler.
  Module Handler.
    Record record {encoding get : Set} := {
      encoding : encoding;
      get : get }.
    Arguments record : clear implicits.
  End Handler.
  Definition Handler_skeleton := Handler.record.
End handler.

Reserved Notation "'handler.Handler".
Reserved Notation "'handler".

Inductive handler_gadt : Set :=
| Handler : forall {a key : Set}, 'handler.Handler a key -> handler_gadt

where "'handler" := (fun (_ : Set) => handler_gadt)
and "'handler.Handler" := (fun (t_a t_key : Set) =>
  handler.Handler_skeleton (Data_encoding.t t_a)
    (t_key -> Z -> Lwt.t (Error_monad.tzresult t_a))).

Module ConstructorRecordNotations_handler_gadt.
  Module handler.
    Definition Handler := 'handler.Handler.
  End handler.
End ConstructorRecordNotations_handler_gadt.
Import ConstructorRecordNotations_handler_gadt.

Definition handler := 'handler.

Module opt_handler.
  Module Opt_handler.
    Record record {encoding get : Set} := {
      encoding : encoding;
      get : get }.
    Arguments record : clear implicits.
  End Opt_handler.
  Definition Opt_handler_skeleton := Opt_handler.record.
End opt_handler.

Reserved Notation "'opt_handler.Opt_handler".
Reserved Notation "'opt_handler".

Inductive opt_handler_gadt : Set :=
| Opt_handler : forall {a key : Set},
  'opt_handler.Opt_handler a key -> opt_handler_gadt

where "'opt_handler" := (fun (_ : Set) => opt_handler_gadt)
and "'opt_handler.Opt_handler" := (fun (t_a t_key : Set) =>
  opt_handler.Opt_handler_skeleton (Data_encoding.t t_a)
    (t_key -> Z -> Lwt.t (Error_monad.tzresult (option t_a)))).

Module ConstructorRecordNotations_opt_handler_gadt.
  Module opt_handler.
    Definition Opt_handler := 'opt_handler.Opt_handler.
  End opt_handler.
End ConstructorRecordNotations_opt_handler_gadt.
Import ConstructorRecordNotations_opt_handler_gadt.

Definition opt_handler := 'opt_handler.

Fixpoint combine_object {A : Set}
  (function_parameter : list (string * opt_handler A))
  {struct function_parameter} : handler A :=
  match function_parameter with
  | [] =>
    obj_magic (handler A)
      (Handler (key := A)
        {| handler.Handler.encoding := Data_encoding.__unit_value;
          handler.Handler.get :=
            fun function_parameter =>
              let '_ := function_parameter in
              fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.return_unit |})
  | cons (name, Opt_handler __handler_value) fields =>
    let 'existT _ __Opt_handler_'a [name, __handler_value, fields] :=
      obj_magic_exists
        (fun __Opt_handler_'a : Set =>
          [string ** (opt_handler.Opt_handler __Opt_handler_'a A) **
            (list (string * opt_handler A))]) [name, __handler_value, fields] in
    obj_magic (handler A)
      (let 'Handler handlers := combine_object fields in
      let 'existT _ __Handler_'a handlers :=
        obj_magic_exists
          (fun __Handler_'a : Set => (handler.Handler __Handler_'a A)) handlers
        in
      obj_magic (handler A)
        (Handler
          {|
            handler.Handler.encoding :=
              Data_encoding.merge_objs
                (Data_encoding.obj1
                  (Data_encoding.opt None None name
                    (Data_encoding.dynamic_size None
                      (opt_handler.Opt_handler.encoding __handler_value))))
                (handler.Handler.encoding handlers);
            handler.Handler.get :=
              fun k =>
                fun i =>
                  Error_monad.op_gtgteqquestion
                    ((opt_handler.Opt_handler.get __handler_value) k i)
                    (fun v1 =>
                      Error_monad.op_gtgteqquestion
                        ((handler.Handler.get handlers) k i)
                        (fun v2 => Error_monad.__return (v1, v2))) |}))
  end.

Module query.
  Record record := Build {
    depth : Z }.
  Definition with_depth depth (r : record) :=
    Build depth.
End query.
Definition query := query.record.

Definition depth_query : RPC_query.t query :=
  Pervasives.op_pipegt
    (RPC_query.op_pipeplus
      (RPC_query.__query_value (fun depth => {| query.depth := depth |}))
      (RPC_query.__field_value None "depth" RPC_arg.int 0
        (fun __t_value => query.depth __t_value))) RPC_query.seal.

Definition build_directory {key : Set} (dir : t key) : RPC_directory.t key :=
  let rpc_dir := Pervasives.__ref_value RPC_directory.empty in
  let register {ikey : Set}
    (path : RPC_path.t key ikey) (function_parameter : opt_handler ikey)
    : unit :=
    let
      'Opt_handler {|
        opt_handler.Opt_handler.encoding := encoding;
          opt_handler.Opt_handler.get := get
          |} := function_parameter in
    let 'existT _ __Opt_handler_'a [encoding, get] :=
      obj_magic_exists
        (fun __Opt_handler_'a : Set =>
          [(Data_encoding.t __Opt_handler_'a) **
            (ikey -> Z -> Lwt.t (Error_monad.tzresult (option __Opt_handler_'a)))])
        [encoding, get] in
    obj_magic unit
      (let service := RPC_service.get_service None depth_query encoding path in
      Pervasives.op_coloneq rpc_dir
        (RPC_directory.register (Pervasives.op_exclamation rpc_dir) service
          (fun k =>
            fun q =>
              fun function_parameter =>
                let '_ := function_parameter in
                Error_monad.op_gtgteqquestion
                  (get k (Pervasives.op_plus (query.depth q) 1))
                  (fun function_parameter =>
                    match function_parameter with
                    | None => Pervasives.raise extensible_type_value
                    | Some x => Error_monad.__return x
                    end)))) in
  let fix build_handler {ikey : Set} (dir : t ikey) (path : RPC_path.t key ikey)
    {struct dir} : opt_handler ikey :=
    match Pervasives.op_exclamation dir with
    | Empty =>
      obj_magic (opt_handler ikey)
        (Opt_handler (key := ikey)
          {| opt_handler.Opt_handler.encoding := Data_encoding.__unit_value;
            opt_handler.Opt_handler.get :=
              fun function_parameter =>
                let '_ := function_parameter in
                fun function_parameter =>
                  let '_ := function_parameter in
                  Error_monad.return_none |})
    |
      Value {|
        description.Value.get := get;
          description.Value.encoding := encoding
          |} =>
      let 'existT _ __Value_'a [get, encoding] :=
        obj_magic_exists
          (fun __Value_'a : Set =>
            [(ikey -> Lwt.t (Error_monad.tzresult (option __Value_'a))) **
              (Data_encoding.t __Value_'a)]) [get, encoding] in
      obj_magic (opt_handler ikey)
        (let __handler_value :=
          Opt_handler
            {| opt_handler.Opt_handler.encoding := encoding;
              opt_handler.Opt_handler.get :=
                fun k =>
                  fun i =>
                    if (|Compare.Int|).(Compare.S.op_lt) i 0 then
                      Error_monad.return_none
                    else
                      get k |} in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        (* ❌ instruction_sequence ";" *)
        __handler_value)
    | NamedDir map =>
      let 'existT _ tt map :=
        obj_magic_exists (fun _ => ((|StringMap|).(S.MAP.t) (t ikey))) map in
      obj_magic (opt_handler ikey)
        (let fields := (|StringMap|).(S.MAP.bindings) map in
        let fields :=
          List.map
            (fun function_parameter =>
              let '(name, dir) := function_parameter in
              (name, (build_handler dir (RPC_path.op_div path name)))) fields in
        let 'Handler __handler_value := combine_object fields in
        let __handler_value :=
          Opt_handler
            {|
              opt_handler.Opt_handler.encoding :=
                handler.Handler.encoding __handler_value;
              opt_handler.Opt_handler.get :=
                fun k =>
                  fun i =>
                    if (|Compare.Int|).(Compare.S.op_lt) i 0 then
                      Error_monad.return_none
                    else
                      Error_monad.op_gtgteqquestion
                        ((handler.Handler.get __handler_value) k
                          (Pervasives.op_minus i 1))
                        (fun v => Error_monad.return_some v) |} in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        (* ❌ instruction_sequence ";" *)
        __handler_value)
    |
      IndexedDir {|
        description.IndexedDir.arg := arg;
          description.IndexedDir.arg_encoding := arg_encoding;
          description.IndexedDir.list := __list_value;
          description.IndexedDir.subdir := subdir
          |} =>
      let 'existT _ __IndexedDir_'a [arg, arg_encoding, __list_value, subdir] :=
        obj_magic_exists
          (fun __IndexedDir_'a : Set =>
            [(RPC_arg.t __IndexedDir_'a) ** (Data_encoding.t __IndexedDir_'a) **
              (ikey -> Lwt.t (Error_monad.tzresult (list __IndexedDir_'a))) **
              (t (ikey * __IndexedDir_'a))])
          [arg, arg_encoding, __list_value, subdir] in
      obj_magic (opt_handler ikey)
        (let 'Opt_handler __handler_value :=
          build_handler subdir (RPC_path.op_divcolon path arg) in
        let 'existT _ __Opt_handler_'a1 __handler_value :=
          obj_magic_exists
            (fun __Opt_handler_'a1 : Set =>
              (opt_handler.Opt_handler __Opt_handler_'a1
                (ikey * __IndexedDir_'a))) __handler_value in
        obj_magic (opt_handler ikey)
          (let encoding :=
            Data_encoding.union None
              [
                Data_encoding.__case_value "Leaf" None (Data_encoding.Tag 0)
                  (Data_encoding.dynamic_size None arg_encoding)
                  (fun function_parameter =>
                    match function_parameter with
                    | (key, None) => Some key
                    | _ => None
                    end) (fun key => (key, None));
                Data_encoding.__case_value "Dir" None (Data_encoding.Tag 1)
                  (Data_encoding.tup2
                    (Data_encoding.dynamic_size None
                      arg_encoding)
                    (Data_encoding.dynamic_size None
                      (opt_handler.Opt_handler.encoding
                        __handler_value)))
                  (fun function_parameter =>
                    match function_parameter with
                    | (key, Some value) =>
                      Some (key, value)
                    | _ => None
                    end)
                  (fun function_parameter =>
                    let '(key, value) :=
                      function_parameter in
                    (key, (Some value)))
              ] in
          let get (k : ikey) (i : (|Compare.Int|).(Compare.S.t))
            : Lwt.t
              (Error_monad.tzresult
                (option (list (__IndexedDir_'a * option __Opt_handler_'a1)))) :=
            if (|Compare.Int|).(Compare.S.op_lt) i 0 then
              Error_monad.return_none
            else
              if (|Compare.Int|).(Compare.S.op_eq) i 0 then
                Error_monad.return_some []
              else
                Error_monad.op_gtgteqquestion (__list_value k)
                  (fun keys =>
                    Error_monad.op_gtgteqquestion
                      (Error_monad.map_s
                        (fun key =>
                          if (|Compare.Int|).(Compare.S.op_eq) i 1 then
                            Error_monad.__return (key, None)
                          else
                            Error_monad.op_gtgteqquestion
                              ((opt_handler.Opt_handler.get __handler_value)
                                (k, key) (Pervasives.op_minus i 1))
                              (fun value => Error_monad.__return (key, value)))
                        keys) (fun values => Error_monad.return_some values)) in
          let __handler_value :=
            Opt_handler
              {|
                opt_handler.Opt_handler.encoding :=
                  Data_encoding.__list_value None
                    (Data_encoding.dynamic_size None encoding);
                opt_handler.Opt_handler.get := get |} in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          (* ❌ instruction_sequence ";" *)
          __handler_value))
    end in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  Pervasives.op_exclamation rpc_dir.

Storage_description_mli

  • OCaml size: 95 lines
  • Coq size: 81 lines (-15% compared to OCaml)
storage_description.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Typed description of the key-value context. *)
type 'key t

(** Trivial display of the key-value context layout. *)
val pp : Format.formatter -> 'key t -> unit

(** Export an RPC hierarchy for querying the context. There is one service
    by possible path in the context. Services for "directory" are able to
    aggregate in one JSON object the whole subtree. *)
val build_directory : 'key t -> 'key RPC_directory.t

(** Create a empty context description,
    keys will be registred by side effects. *)
val create : unit -> 'key t

(** Register a single key accessor at a given path. *)
val register_value :
  'key t ->
  get:('key -> 'a option tzresult Lwt.t) ->
  'a Data_encoding.t ->
  unit

(** Return a description for a prefixed fragment of the given context.
    All keys registred in the subcontext will be shared by the external
    context *)
val register_named_subcontext : 'key t -> string list -> 'key t

(** Description of an index as a sequence of `RPC_arg.t`. *)
type (_, _, _) args =
  | One : {
      rpc_arg : 'a RPC_arg.t;
      encoding : 'a Data_encoding.t;
      compare : 'a -> 'a -> int;
    }
      -> ('key, 'a, 'key * 'a) args
  | Pair :
      ('key, 'a, 'inter_key) args * ('inter_key, 'b, 'sub_key) args
      -> ('key, 'a * 'b, 'sub_key) args

(** Return a description for a indexed sub-context.
    All keys registred in the subcontext will be shared by the external
    context. One should provide a function to list all the registred
    index in the context. *)
val register_indexed_subcontext :
  'key t ->
  list:('key -> 'arg list tzresult Lwt.t) ->
  ('key, 'arg, 'sub_key) args ->
  'sub_key t

(** Helpers for manipulating and defining indexes. *)

val pack : ('key, 'a, 'sub_key) args -> 'key -> 'a -> 'sub_key

val unpack : ('key, 'a, 'sub_key) args -> 'sub_key -> 'key * 'a

module type INDEX = sig
  type t

  val path_length : int

  val to_path : t -> string list -> string list

  val of_path : string list -> t option

  val rpc_arg : t RPC_arg.t

  val encoding : t Data_encoding.t

  val compare : t -> t -> int
end
Storage_description_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Parameter t : forall (key : Set), Set.

Parameter pp : forall {key : Set}, Format.formatter -> t key -> unit.

Parameter build_directory : forall {key : Set}, t key -> RPC_directory.t key.

Parameter create : forall {key : Set}, unit -> t key.

Parameter register_value : forall {a key : Set},
  t key -> (key -> Lwt.t (Error_monad.tzresult (option a))) ->
  Data_encoding.t a -> unit.

Parameter register_named_subcontext : forall {key : Set},
  t key -> list string -> t key.

Module args.
  Module One.
    Record record {rpc_arg encoding compare : Set} := {
      rpc_arg : rpc_arg;
      encoding : encoding;
      compare : compare }.
    Arguments record : clear implicits.
  End One.
  Definition One_skeleton := One.record.
End args.

Reserved Notation "'args.One".
Reserved Notation "'args".

Inductive args_gadt : Set :=
| One : forall {a : Set}, 'args.One a -> args_gadt
| Pair : args_gadt -> args_gadt -> args_gadt

where "'args" := (fun (_ _ _ : Set) => args_gadt)
and "'args.One" := (fun (t_a : Set) =>
  args.One_skeleton (RPC_arg.t t_a) (Data_encoding.t t_a) (t_a -> t_a -> Z)).

Module ConstructorRecordNotations_args_gadt.
  Module args.
    Definition One := 'args.One.
  End args.
End ConstructorRecordNotations_args_gadt.
Import ConstructorRecordNotations_args_gadt.

Definition args := 'args.

Parameter register_indexed_subcontext : forall {arg key sub_key : Set},
  t key -> (key -> Lwt.t (Error_monad.tzresult (list arg))) ->
  args key arg sub_key -> t sub_key.

Parameter pack : forall {a key sub_key : Set},
  args key a sub_key -> key -> a -> sub_key.

Parameter unpack : forall {a key sub_key : Set},
  args key a sub_key -> sub_key -> key * a.

Module INDEX.
  Record signature {t : Set} := {
    t := t;
    path_length : Z;
    to_path : t -> list string -> list string;
    of_path : list string -> option t;
    rpc_arg : RPC_arg.t t;
    encoding : Data_encoding.t t;
    compare : t -> t -> Z;
  }.
  Arguments signature : clear implicits.
End INDEX.

Storage_functors

  • OCaml size: 1143 lines
  • Coq size: 1320 lines (+15% compared to OCaml)
storage_functors.ml 172 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Storage_sigs

module Registered = struct
  let ghost = false
end

module Ghost = struct
  let ghost = true
end

module Make_encoder (V : VALUE) = struct
  let of_bytes ~key b =
    match Data_encoding.Binary.of_bytes V.encoding b with
    | None ->
        error (Raw_context.Storage_error (Corrupted_data key))
    | Some v ->
        Ok v

  let to_bytes v =
    match Data_encoding.Binary.to_bytes V.encoding v with
    | Some b ->
        b
    | None ->
        MBytes.create 0
end

let len_name = "len"

let data_name = "data"

let encode_len_value bytes =
  let length = MBytes.length bytes in
  Data_encoding.(Binary.to_bytes_exn int31) length

let decode_len_value key len =
  match Data_encoding.(Binary.of_bytes int31) len with
  | None ->
      fail (Raw_context.Storage_error (Corrupted_data key))
  | Some len ->
      return len

let map_key f = function `Key k -> `Key (f k) | `Dir k -> `Dir (f k)

module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) :
  Raw_context.T with type t = C.t = struct
  type t = C.t

  type context = t

  let name_length = List.length N.name

  let to_key k = N.name @ k

  let of_key k = Misc.remove_elem_from_list name_length k

  let mem t k = C.mem t (to_key k)

  let dir_mem t k = C.dir_mem t (to_key k)

  let get t k = C.get t (to_key k)

  let get_option t k = C.get_option t (to_key k)

  let init t k v = C.init t (to_key k) v

  let set t k v = C.set t (to_key k) v

  let init_set t k v = C.init_set t (to_key k) v

  let set_option t k v = C.set_option t (to_key k) v

  let delete t k = C.delete t (to_key k)

  let remove t k = C.remove t (to_key k)

  let remove_rec t k = C.remove_rec t (to_key k)

  let copy t ~from ~to_ = C.copy t ~from:(to_key from) ~to_:(to_key to_)

  let fold t k ~init ~f =
    C.fold t (to_key k) ~init ~f:(fun k acc -> f (map_key of_key k) acc)

  let keys t k = C.keys t (to_key k) >|= fun keys -> List.map of_key keys

  let fold_keys t k ~init ~f =
    C.fold_keys t (to_key k) ~init ~f:(fun k acc -> f (of_key k) acc)

  let project = C.project

  let absolute_key c k = C.absolute_key c (to_key k)

  let consume_gas = C.consume_gas

  let check_enough_gas = C.check_enough_gas

  let description =
    let description =
      if R.ghost then Storage_description.create () else C.description
    in
    Storage_description.register_named_subcontext description N.name
end

module Make_single_data_storage
    (R : REGISTER)
    (C : Raw_context.T)
    (N : NAME)
    (V : VALUE) : Single_data_storage with type t = C.t and type value = V.t =
struct
  type t = C.t

  type context = t

  type value = V.t

  let mem t = C.mem t N.name

  include Make_encoder (V)

  let get t =
    C.get t N.name
    >>=? fun b ->
    let key = C.absolute_key t N.name in
    Lwt.return (of_bytes ~key b)

  let get_option t =
    C.get_option t N.name
    >>= function
    | None ->
        return_none
    | Some b -> (
        let key = C.absolute_key t N.name in
        match of_bytes ~key b with
        | Ok v ->
            return_some v
        | Error _ as err ->
            Lwt.return err )

  let init t v =
    C.init t N.name (to_bytes v) >>=? fun t -> return (C.project t)

  let set t v = C.set t N.name (to_bytes v) >>=? fun t -> return (C.project t)

  let init_set t v =
    C.init_set t N.name (to_bytes v) >>= fun t -> Lwt.return (C.project t)

  let set_option t v =
    C.set_option t N.name (Option.map ~f:to_bytes v)
    >>= fun t -> Lwt.return (C.project t)

  let remove t = C.remove t N.name >>= fun t -> Lwt.return (C.project t)

  let delete t = C.delete t N.name >>=? fun t -> return (C.project t)

  let () =
    let open Storage_description in
    let description =
      if R.ghost then Storage_description.create () else C.description
    in
    register_value
      ~get:get_option
      (register_named_subcontext description N.name)
      V.encoding
end

module type INDEX = sig
  type t

  val path_length : int

  val to_path : t -> string list -> string list

  val of_path : string list -> t option

  type 'a ipath

  val args : ('a, t, 'a ipath) Storage_description.args
end

module Pair (I1 : INDEX) (I2 : INDEX) : INDEX with type t = I1.t * I2.t =
struct
  type t = I1.t * I2.t

  let path_length = I1.path_length + I2.path_length

  let to_path (x, y) l = I1.to_path x (I2.to_path y l)

  let of_path l =
    match Misc.take I1.path_length l with
    | None ->
        None
    | Some (l1, l2) -> (
      match (I1.of_path l1, I2.of_path l2) with
      | (Some x, Some y) ->
          Some (x, y)
      | _ ->
          None )

  type 'a ipath = 'a I1.ipath I2.ipath

  let args = Storage_description.Pair (I1.args, I2.args)
end

module Make_data_set_storage (C : Raw_context.T) (I : INDEX) :
  Data_set_storage with type t = C.t and type elt = I.t = struct
  type t = C.t

  type context = t

  type elt = I.t

  let inited = MBytes.of_string "inited"

  let mem s i = C.mem s (I.to_path i [])

  let add s i =
    C.init_set s (I.to_path i []) inited >>= fun t -> Lwt.return (C.project t)

  let del s i =
    C.remove s (I.to_path i []) >>= fun t -> Lwt.return (C.project t)

  let set s i = function true -> add s i | false -> del s i

  let clear s = C.remove_rec s [] >>= fun t -> Lwt.return (C.project t)

  let fold s ~init ~f =
    let rec dig i path acc =
      if Compare.Int.(i <= 1) then
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir _ ->
                Lwt.return acc
            | `Key file -> (
              match I.of_path file with
              | None ->
                  assert false
              | Some p ->
                  f p acc ))
      else
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

  let () =
    let open Storage_description in
    let unpack = unpack I.args in
    register_value (* TODO fixme 'elements...' *)
      ~get:(fun c ->
        let (c, k) = unpack c in
        mem c k >>= function true -> return_some true | false -> return_none)
      (register_indexed_subcontext
         ~list:(fun c -> elements c >>= return)
         C.description
         I.args)
      Data_encoding.bool
end

module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) :
  Indexed_data_storage
    with type t = C.t
     and type key = I.t
     and type value = V.t = struct
  type t = C.t

  type context = t

  type key = I.t

  type value = V.t

  include Make_encoder (V)

  let mem s i = C.mem s (I.to_path i [])

  let get s i =
    C.get s (I.to_path i [])
    >>=? fun b ->
    let key = C.absolute_key s (I.to_path i []) in
    Lwt.return (of_bytes ~key b)

  let get_option s i =
    C.get_option s (I.to_path i [])
    >>= function
    | None ->
        return_none
    | Some b -> (
        let key = C.absolute_key s (I.to_path i []) in
        match of_bytes ~key b with
        | Ok v ->
            return_some v
        | Error _ as err ->
            Lwt.return err )

  let set s i v =
    C.set s (I.to_path i []) (to_bytes v) >>=? fun t -> return (C.project t)

  let init s i v =
    C.init s (I.to_path i []) (to_bytes v) >>=? fun t -> return (C.project t)

  let init_set s i v =
    C.init_set s (I.to_path i []) (to_bytes v)
    >>= fun t -> Lwt.return (C.project t)

  let set_option s i v =
    C.set_option s (I.to_path i []) (Option.map ~f:to_bytes v)
    >>= fun t -> Lwt.return (C.project t)

  let remove s i =
    C.remove s (I.to_path i []) >>= fun t -> Lwt.return (C.project t)

  let delete s i =
    C.delete s (I.to_path i []) >>=? fun t -> return (C.project t)

  let clear s = C.remove_rec s [] >>= fun t -> Lwt.return (C.project t)

  let fold_keys s ~init ~f =
    let rec dig i path acc =
      if Compare.Int.(i <= 1) then
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir _ ->
                Lwt.return acc
            | `Key file -> (
              match I.of_path file with
              | None ->
                  assert false
              | Some path ->
                  f path acc ))
      else
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let fold s ~init ~f =
    let f path acc =
      get s path
      >>= function
      | Error _ ->
          (* FIXME: silently ignore unparsable data *)
          Lwt.return acc
      | Ok v ->
          f path v acc
    in
    fold_keys s ~init ~f

  let bindings s =
    fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))

  let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

  let () =
    let open Storage_description in
    let unpack = unpack I.args in
    register_value
      ~get:(fun c ->
        let (c, k) = unpack c in
        get_option c k)
      (register_indexed_subcontext
         ~list:(fun c -> keys c >>= return)
         C.description
         I.args)
      V.encoding
end

module Make_indexed_carbonated_data_storage
    (C : Raw_context.T)
    (I : INDEX)
    (V : VALUE) :
  Non_iterable_indexed_carbonated_data_storage
    with type t = C.t
     and type key = I.t
     and type value = V.t = struct
  type t = C.t

  type context = t

  type key = I.t

  type value = V.t

  include Make_encoder (V)

  let data_key i = I.to_path i [data_name]

  let len_key i = I.to_path i [len_name]

  let consume_mem_gas c =
    Lwt.return (C.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))

  let existing_size c i =
    C.get_option c (len_key i)
    >>= function
    | None ->
        return (0, false)
    | Some len ->
        decode_len_value (len_key i) len >>=? fun len -> return (len, true)

  let consume_read_gas get c i =
    get c (len_key i)
    >>=? fun len ->
    decode_len_value (len_key i) len
    >>=? fun len ->
    Lwt.return
      (C.consume_gas c (Gas_limit_repr.read_bytes_cost (Z.of_int len)))

  let consume_serialize_write_gas set c i v =
    let bytes = to_bytes v in
    let len = MBytes.length bytes in
    Lwt.return (C.consume_gas c (Gas_limit_repr.alloc_mbytes_cost len))
    >>=? fun c ->
    Lwt.return
      (C.consume_gas c (Gas_limit_repr.write_bytes_cost (Z.of_int len)))
    >>=? fun c ->
    set c (len_key i) (encode_len_value bytes) >>=? fun c -> return (c, bytes)

  let consume_remove_gas del c i =
    Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero))
    >>=? fun c -> del c (len_key i)

  let mem s i =
    consume_mem_gas s
    >>=? fun s ->
    C.mem s (data_key i) >>= fun exists -> return (C.project s, exists)

  let get s i =
    consume_read_gas C.get s i
    >>=? fun s ->
    C.get s (data_key i)
    >>=? fun b ->
    let key = C.absolute_key s (data_key i) in
    Lwt.return (of_bytes ~key b) >>=? fun v -> return (C.project s, v)

  let get_option s i =
    consume_mem_gas s
    >>=? fun s ->
    C.mem s (data_key i)
    >>= fun exists ->
    if exists then get s i >>=? fun (s, v) -> return (s, Some v)
    else return (C.project s, None)

  let set s i v =
    existing_size s i
    >>=? fun (prev_size, _) ->
    consume_serialize_write_gas C.set s i v
    >>=? fun (s, bytes) ->
    C.set s (data_key i) bytes
    >>=? fun t ->
    let size_diff = MBytes.length bytes - prev_size in
    return (C.project t, size_diff)

  let init s i v =
    consume_serialize_write_gas C.init s i v
    >>=? fun (s, bytes) ->
    C.init s (data_key i) bytes
    >>=? fun t ->
    let size = MBytes.length bytes in
    return (C.project t, size)

  let init_set s i v =
    let init_set s i v = C.init_set s i v >>= return in
    existing_size s i
    >>=? fun (prev_size, existed) ->
    consume_serialize_write_gas init_set s i v
    >>=? fun (s, bytes) ->
    init_set s (data_key i) bytes
    >>=? fun t ->
    let size_diff = MBytes.length bytes - prev_size in
    return (C.project t, size_diff, existed)

  let remove s i =
    let remove s i = C.remove s i >>= return in
    existing_size s i
    >>=? fun (prev_size, existed) ->
    consume_remove_gas remove s i
    >>=? fun s ->
    remove s (data_key i) >>=? fun t -> return (C.project t, prev_size, existed)

  let delete s i =
    existing_size s i
    >>=? fun (prev_size, _) ->
    consume_remove_gas C.delete s i
    >>=? fun s ->
    C.delete s (data_key i) >>=? fun t -> return (C.project t, prev_size)

  let set_option s i v =
    match v with None -> remove s i | Some v -> init_set s i v

  let fold_keys_unaccounted s ~init ~f =
    let rec dig i path acc =
      if Compare.Int.(i <= 0) then
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir _ ->
                Lwt.return acc
            | `Key file -> (
              match List.rev file with
              | last :: _ when Compare.String.(last = len_name) ->
                  Lwt.return acc
              | last :: rest when Compare.String.(last = data_name) -> (
                  let file = List.rev rest in
                  match I.of_path file with
                  | None ->
                      assert false
                  | Some path ->
                      f path acc )
              | _ ->
                  assert false ))
      else
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let keys_unaccounted s =
    fold_keys_unaccounted s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

  let () =
    let open Storage_description in
    let unpack = unpack I.args in
    register_value (* TODO export consumed gas ?? *)
      ~get:(fun c ->
        let (c, k) = unpack c in
        get_option c k >>=? fun (_, v) -> return v)
      (register_indexed_subcontext
         ~list:(fun c -> keys_unaccounted c >>= return)
         C.description
         I.args)
      V.encoding
end

module Make_indexed_data_snapshotable_storage
    (C : Raw_context.T)
    (Snapshot_index : INDEX)
    (I : INDEX)
    (V : VALUE) :
  Indexed_data_snapshotable_storage
    with type t = C.t
     and type snapshot = Snapshot_index.t
     and type key = I.t
     and type value = V.t = struct
  type snapshot = Snapshot_index.t

  let data_name = ["current"]

  let snapshot_name = ["snapshot"]

  module C_data =
    Make_subcontext (Registered) (C)
      (struct
        let name = data_name
      end)

  module C_snapshot =
    Make_subcontext (Registered) (C)
      (struct
        let name = snapshot_name
      end)

  include Make_indexed_data_storage (C_data) (I) (V)
  module Snapshot =
    Make_indexed_data_storage (C_snapshot) (Pair (Snapshot_index) (I)) (V)

  let snapshot_path id = snapshot_name @ Snapshot_index.to_path id []

  let snapshot_exists s id = C.dir_mem s (snapshot_path id)

  let snapshot s id =
    C.copy s ~from:data_name ~to_:(snapshot_path id)
    >>=? fun t -> return (C.project t)

  let delete_snapshot s id =
    C.remove_rec s (snapshot_path id) >>= fun t -> Lwt.return (C.project t)
end

module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) :
  Indexed_raw_context
    with type t = C.t
     and type key = I.t
     and type 'a ipath = 'a I.ipath = struct
  type t = C.t

  type context = t

  type key = I.t

  type 'a ipath = 'a I.ipath

  let clear t = C.remove_rec t [] >>= fun t -> Lwt.return (C.project t)

  let fold_keys t ~init ~f =
    let rec dig i path acc =
      if Compare.Int.(i <= 0) then
        match I.of_path path with
        | None ->
            assert false
        | Some path ->
            f path acc
      else
        C.fold t path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let keys t = fold_keys t ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc))

  let list t k = C.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))

  let remove_rec t k = C.remove_rec t (I.to_path k [])

  let copy t ~from ~to_ =
    C.copy t ~from:(I.to_path from []) ~to_:(I.to_path to_ [])

  let description =
    Storage_description.register_indexed_subcontext
      ~list:(fun c -> keys c >>= return)
      C.description
      I.args

  let unpack = Storage_description.unpack I.args

  let pack = Storage_description.pack I.args

  module Raw_context = struct
    type t = C.t I.ipath

    type context = t

    let to_key i k = I.to_path i k

    let of_key k = Misc.remove_elem_from_list I.path_length k

    let mem c k =
      let (t, i) = unpack c in
      C.mem t (to_key i k)

    let dir_mem c k =
      let (t, i) = unpack c in
      C.dir_mem t (to_key i k)

    let get c k =
      let (t, i) = unpack c in
      C.get t (to_key i k)

    let get_option c k =
      let (t, i) = unpack c in
      C.get_option t (to_key i k)

    let init c k v =
      let (t, i) = unpack c in
      C.init t (to_key i k) v >>=? fun t -> return (pack t i)

    let set c k v =
      let (t, i) = unpack c in
      C.set t (to_key i k) v >>=? fun t -> return (pack t i)

    let init_set c k v =
      let (t, i) = unpack c in
      C.init_set t (to_key i k) v >>= fun t -> Lwt.return (pack t i)

    let set_option c k v =
      let (t, i) = unpack c in
      C.set_option t (to_key i k) v >>= fun t -> Lwt.return (pack t i)

    let delete c k =
      let (t, i) = unpack c in
      C.delete t (to_key i k) >>=? fun t -> return (pack t i)

    let remove c k =
      let (t, i) = unpack c in
      C.remove t (to_key i k) >>= fun t -> Lwt.return (pack t i)

    let remove_rec c k =
      let (t, i) = unpack c in
      C.remove_rec t (to_key i k) >>= fun t -> Lwt.return (pack t i)

    let copy c ~from ~to_ =
      let (t, i) = unpack c in
      C.copy t ~from:(to_key i from) ~to_:(to_key i to_)
      >>=? fun t -> return (pack t i)

    let fold c k ~init ~f =
      let (t, i) = unpack c in
      C.fold t (to_key i k) ~init ~f:(fun k acc -> f (map_key of_key k) acc)

    let keys c k =
      let (t, i) = unpack c in
      C.keys t (to_key i k) >|= fun keys -> List.map of_key keys

    let fold_keys c k ~init ~f =
      let (t, i) = unpack c in
      C.fold_keys t (to_key i k) ~init ~f:(fun k acc -> f (of_key k) acc)

    let project c =
      let (t, _) = unpack c in
      C.project t

    let absolute_key c k =
      let (t, i) = unpack c in
      C.absolute_key t (to_key i k)

    let consume_gas c g =
      let (t, i) = unpack c in
      C.consume_gas t g >>? fun t -> ok (pack t i)

    let check_enough_gas c g =
      let (t, _i) = unpack c in
      C.check_enough_gas t g

    let description = description
  end

  let resolve t prefix =
    let rec loop i prefix = function
      | [] when Compare.Int.(i = I.path_length) -> (
        match I.of_path prefix with
        | None ->
            assert false
        | Some path ->
            Lwt.return [path] )
      | [] ->
          list t prefix
          >>= fun prefixes ->
          Lwt_list.map_s
            (function `Key prefix | `Dir prefix -> loop (i + 1) prefix [])
            prefixes
          >|= List.flatten
      | [d] when Compare.Int.(i = I.path_length - 1) ->
          if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ;
          list t prefix
          >>= fun prefixes ->
          Lwt_list.map_s
            (function
              | `Key prefix | `Dir prefix -> (
                match
                  Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix))
                with
                | None ->
                    Lwt.return_nil
                | Some _ ->
                    loop (i + 1) prefix [] ))
            prefixes
          >|= List.flatten
      | "" :: ds ->
          list t prefix
          >>= fun prefixes ->
          Lwt_list.map_s
            (function `Key prefix | `Dir prefix -> loop (i + 1) prefix ds)
            prefixes
          >|= List.flatten
      | d :: ds -> (
          if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ;
          C.dir_mem t (prefix @ [d])
          >>= function
          | true -> loop (i + 1) (prefix @ [d]) ds | false -> Lwt.return_nil )
    in
    loop 0 [] prefix

  module Make_set (R : REGISTER) (N : NAME) = struct
    type t = C.t

    type context = t

    type elt = I.t

    let inited = MBytes.of_string "inited"

    let mem s i = Raw_context.mem (pack s i) N.name

    let add s i =
      Raw_context.init_set (pack s i) N.name inited
      >>= fun c ->
      let (s, _) = unpack c in
      Lwt.return (C.project s)

    let del s i =
      Raw_context.remove (pack s i) N.name
      >>= fun c ->
      let (s, _) = unpack c in
      Lwt.return (C.project s)

    let set s i = function true -> add s i | false -> del s i

    let clear s =
      fold_keys s ~init:s ~f:(fun i s ->
          Raw_context.remove (pack s i) N.name
          >>= fun c ->
          let (s, _) = unpack c in
          Lwt.return s)
      >>= fun t -> Lwt.return (C.project t)

    let fold s ~init ~f =
      fold_keys s ~init ~f:(fun i acc ->
          mem s i >>= function true -> f i acc | false -> Lwt.return acc)

    let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

    let () =
      let open Storage_description in
      let unpack = unpack I.args in
      let description =
        if R.ghost then Storage_description.create ()
        else Raw_context.description
      in
      register_value
        ~get:(fun c ->
          let (c, k) = unpack c in
          mem c k
          >>= function true -> return_some true | false -> return_none)
        (register_named_subcontext description N.name)
        Data_encoding.bool
  end

  module Make_map (N : NAME) (V : VALUE) = struct
    type t = C.t

    type context = t

    type key = I.t

    type value = V.t

    include Make_encoder (V)

    let mem s i = Raw_context.mem (pack s i) N.name

    let get s i =
      Raw_context.get (pack s i) N.name
      >>=? fun b ->
      let key = Raw_context.absolute_key (pack s i) N.name in
      Lwt.return (of_bytes ~key b)

    let get_option s i =
      Raw_context.get_option (pack s i) N.name
      >>= function
      | None ->
          return_none
      | Some b -> (
          let key = Raw_context.absolute_key (pack s i) N.name in
          match of_bytes ~key b with
          | Ok v ->
              return_some v
          | Error _ as err ->
              Lwt.return err )

    let set s i v =
      Raw_context.set (pack s i) N.name (to_bytes v)
      >>=? fun c ->
      let (s, _) = unpack c in
      return (C.project s)

    let init s i v =
      Raw_context.init (pack s i) N.name (to_bytes v)
      >>=? fun c ->
      let (s, _) = unpack c in
      return (C.project s)

    let init_set s i v =
      Raw_context.init_set (pack s i) N.name (to_bytes v)
      >>= fun c ->
      let (s, _) = unpack c in
      Lwt.return (C.project s)

    let set_option s i v =
      Raw_context.set_option (pack s i) N.name (Option.map ~f:to_bytes v)
      >>= fun c ->
      let (s, _) = unpack c in
      Lwt.return (C.project s)

    let remove s i =
      Raw_context.remove (pack s i) N.name
      >>= fun c ->
      let (s, _) = unpack c in
      Lwt.return (C.project s)

    let delete s i =
      Raw_context.delete (pack s i) N.name
      >>=? fun c ->
      let (s, _) = unpack c in
      return (C.project s)

    let clear s =
      fold_keys s ~init:s ~f:(fun i s ->
          Raw_context.remove (pack s i) N.name
          >>= fun c ->
          let (s, _) = unpack c in
          Lwt.return s)
      >>= fun t -> Lwt.return (C.project t)

    let fold s ~init ~f =
      fold_keys s ~init ~f:(fun i acc ->
          get s i >>= function Error _ -> Lwt.return acc | Ok v -> f i v acc)

    let bindings s =
      fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))

    let fold_keys s ~init ~f =
      fold_keys s ~init ~f:(fun i acc ->
          mem s i >>= function false -> Lwt.return acc | true -> f i acc)

    let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

    let () =
      let open Storage_description in
      let unpack = unpack I.args in
      register_value
        ~get:(fun c ->
          let (c, k) = unpack c in
          get_option c k)
        (register_named_subcontext Raw_context.description N.name)
        V.encoding
  end

  module Make_carbonated_map (N : NAME) (V : VALUE) = struct
    type t = C.t

    type context = t

    type key = I.t

    type value = V.t

    include Make_encoder (V)

    let len_name = len_name :: N.name

    let data_name = data_name :: N.name

    let consume_mem_gas c =
      Lwt.return
        (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))

    let existing_size c =
      Raw_context.get_option c len_name
      >>= function
      | None ->
          return (0, false)
      | Some len ->
          decode_len_value len_name len >>=? fun len -> return (len, true)

    let consume_read_gas get c =
      get c len_name
      >>=? fun len ->
      decode_len_value len_name len
      >>=? fun len ->
      Lwt.return
        (Raw_context.consume_gas
           c
           (Gas_limit_repr.read_bytes_cost (Z.of_int len)))

    let consume_write_gas set c v =
      let bytes = to_bytes v in
      let len = MBytes.length bytes in
      Lwt.return
        (Raw_context.consume_gas
           c
           (Gas_limit_repr.write_bytes_cost (Z.of_int len)))
      >>=? fun c ->
      set c len_name (encode_len_value bytes) >>=? fun c -> return (c, bytes)

    let consume_remove_gas del c =
      Lwt.return
        (Raw_context.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero))
      >>=? fun c -> del c len_name

    let mem s i =
      consume_mem_gas (pack s i)
      >>=? fun c ->
      Raw_context.mem c data_name
      >>= fun res -> return (Raw_context.project c, res)

    let get s i =
      consume_read_gas Raw_context.get (pack s i)
      >>=? fun c ->
      Raw_context.get c data_name
      >>=? fun b ->
      let key = Raw_context.absolute_key c data_name in
      Lwt.return (of_bytes ~key b)
      >>=? fun v -> return (Raw_context.project c, v)

    let get_option s i =
      consume_mem_gas (pack s i)
      >>=? fun c ->
      let (s, _) = unpack c in
      Raw_context.mem (pack s i) data_name
      >>= fun exists ->
      if exists then get s i >>=? fun (s, v) -> return (s, Some v)
      else return (C.project s, None)

    let set s i v =
      existing_size (pack s i)
      >>=? fun (prev_size, _) ->
      consume_write_gas Raw_context.set (pack s i) v
      >>=? fun (c, bytes) ->
      Raw_context.set c data_name bytes
      >>=? fun c ->
      let size_diff = MBytes.length bytes - prev_size in
      return (Raw_context.project c, size_diff)

    let init s i v =
      consume_write_gas Raw_context.init (pack s i) v
      >>=? fun (c, bytes) ->
      Raw_context.init c data_name bytes
      >>=? fun c ->
      let size = MBytes.length bytes in
      return (Raw_context.project c, size)

    let init_set s i v =
      let init_set c k v = Raw_context.init_set c k v >>= return in
      existing_size (pack s i)
      >>=? fun (prev_size, existed) ->
      consume_write_gas init_set (pack s i) v
      >>=? fun (c, bytes) ->
      init_set c data_name bytes
      >>=? fun c ->
      let size_diff = MBytes.length bytes - prev_size in
      return (Raw_context.project c, size_diff, existed)

    let remove s i =
      let remove c k = Raw_context.remove c k >>= return in
      existing_size (pack s i)
      >>=? fun (prev_size, existed) ->
      consume_remove_gas remove (pack s i)
      >>=? fun c ->
      remove c data_name
      >>=? fun c -> return (Raw_context.project c, prev_size, existed)

    let delete s i =
      existing_size (pack s i)
      >>=? fun (prev_size, _) ->
      consume_remove_gas Raw_context.delete (pack s i)
      >>=? fun c ->
      Raw_context.delete c data_name
      >>=? fun c -> return (Raw_context.project c, prev_size)

    let set_option s i v =
      match v with None -> remove s i | Some v -> init_set s i v

    let () =
      let open Storage_description in
      let unpack = unpack I.args in
      register_value
        ~get:(fun c ->
          let (c, k) = unpack c in
          get_option c k >>=? fun (_, v) -> return v)
        (register_named_subcontext Raw_context.description N.name)
        V.encoding
  end
end

module Wrap_indexed_data_storage
    (C : Indexed_data_storage) (K : sig
      type t

      val wrap : t -> C.key

      val unwrap : C.key -> t option
    end) =
struct
  type t = C.t

  type context = C.t

  type key = K.t

  type value = C.value

  let mem ctxt k = C.mem ctxt (K.wrap k)

  let get ctxt k = C.get ctxt (K.wrap k)

  let get_option ctxt k = C.get_option ctxt (K.wrap k)

  let set ctxt k v = C.set ctxt (K.wrap k) v

  let init ctxt k v = C.init ctxt (K.wrap k) v

  let init_set ctxt k v = C.init_set ctxt (K.wrap k) v

  let set_option ctxt k v = C.set_option ctxt (K.wrap k) v

  let delete ctxt k = C.delete ctxt (K.wrap k)

  let remove ctxt k = C.remove ctxt (K.wrap k)

  let clear ctxt = C.clear ctxt

  let fold ctxt ~init ~f =
    C.fold ctxt ~init ~f:(fun k v acc ->
        match K.unwrap k with None -> Lwt.return acc | Some k -> f k v acc)

  let bindings s =
    fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))

  let fold_keys s ~init ~f =
    C.fold_keys s ~init ~f:(fun k acc ->
        match K.unwrap k with None -> Lwt.return acc | Some k -> f k acc)

  let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
end
Storage_functors.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Gas_limit_repr.
Require Tezos.Misc.
Require Tezos.Raw_context.
Require Tezos.Storage_description.
Require Tezos.Storage_sigs.

Import Storage_sigs.

Definition Registered :=
  let ghost := false in
  existT (fun _ => _) tt
    {|
      Storage_sigs.REGISTER.ghost := ghost
    |}.

Definition Ghost :=
  let ghost := true in
  existT (fun _ => _) tt
    {|
      Storage_sigs.REGISTER.ghost := ghost
    |}.

Definition Make_encoder :=
  fun (V : {t : _ & VALUE.signature t}) =>
    (* ❌ The signature name of this module could not be found *)
    first_class_module_value_of_unknown_signature.

Definition len_name : string := "len".

Definition data_name : string := "data".

Definition encode_len_value (__bytes_value : MBytes.t) : MBytes.t :=
  let length := MBytes.length __bytes_value in
  (Data_encoding.Binary.to_bytes_exn Data_encoding.int31) length.

Definition decode_len_value (key : list string) (len : MBytes.t)
  : Lwt.t (Error_monad.tzresult Z) :=
  match (Data_encoding.Binary.of_bytes Data_encoding.int31) len with
  | None => Error_monad.fail extensible_type_value
  | Some len => Error_monad.__return len
  end.

Definition map_key {A B : Set} (f : A -> B) (function_parameter : (* `Key *) A)
  : (* `Key *) B :=
  match function_parameter with
  | Key k =>
    (* ❌ Variants not supported *)
    (* ❌ `Key *)
    Key (f k)
  | Dir k =>
    (* ❌ Variants not supported *)
    (* ❌ `Dir *)
    Dir (f k)
  end.

Definition Make_subcontext :=
  fun (R : {_ : unit & REGISTER.signature}) =>
    fun (C : {t : _ & Raw_context.T.signature t}) =>
      fun (N : {_ : unit & NAME.signature}) =>
        (let t := (|C|).(Raw_context.T.t) in
        let context := t in
        let name_length := List.length (|N|).(Storage_sigs.NAME.name) in
        let to_key (k : list string) : list string :=
          Pervasives.op_at (|N|).(Storage_sigs.NAME.name) k in
        let of_key {A : Set} (k : list A) : list A :=
          Misc.remove_elem_from_list name_length k in
        let mem (__t_value : (|C|).(Raw_context.T.context)) (k : list string)
          : Lwt.t bool :=
          (|C|).(Raw_context.T.mem) __t_value (to_key k) in
        let dir_mem
          (__t_value : (|C|).(Raw_context.T.context)) (k : list string)
          : Lwt.t bool :=
          (|C|).(Raw_context.T.dir_mem) __t_value (to_key k) in
        let get (__t_value : (|C|).(Raw_context.T.context)) (k : list string)
          : Lwt.t (Error_monad.tzresult Raw_context.value) :=
          (|C|).(Raw_context.T.get) __t_value (to_key k) in
        let get_option
          (__t_value : (|C|).(Raw_context.T.context)) (k : list string)
          : Lwt.t (option Raw_context.value) :=
          (|C|).(Raw_context.T.get_option) __t_value (to_key k) in
        let init
          (__t_value : (|C|).(Raw_context.T.context)) (k : list string)
          (v : Raw_context.value)
          : Lwt.t (Error_monad.tzresult (|C|).(Raw_context.T.context)) :=
          (|C|).(Raw_context.T.init) __t_value (to_key k) v in
        let set
          (__t_value : (|C|).(Raw_context.T.context)) (k : list string)
          (v : Raw_context.value)
          : Lwt.t (Error_monad.tzresult (|C|).(Raw_context.T.context)) :=
          (|C|).(Raw_context.T.set) __t_value (to_key k) v in
        let init_set
          (__t_value : (|C|).(Raw_context.T.context)) (k : list string)
          (v : Raw_context.value) : Lwt.t (|C|).(Raw_context.T.context) :=
          (|C|).(Raw_context.T.init_set) __t_value (to_key k) v in
        let set_option
          (__t_value : (|C|).(Raw_context.T.context)) (k : list string)
          (v : option Raw_context.value)
          : Lwt.t (|C|).(Raw_context.T.context) :=
          (|C|).(Raw_context.T.set_option) __t_value (to_key k) v in
        let delete (__t_value : (|C|).(Raw_context.T.context)) (k : list string)
          : Lwt.t (Error_monad.tzresult (|C|).(Raw_context.T.context)) :=
          (|C|).(Raw_context.T.delete) __t_value (to_key k) in
        let remove (__t_value : (|C|).(Raw_context.T.context)) (k : list string)
          : Lwt.t (|C|).(Raw_context.T.context) :=
          (|C|).(Raw_context.T.remove) __t_value (to_key k) in
        let remove_rec
          (__t_value : (|C|).(Raw_context.T.context)) (k : list string)
          : Lwt.t (|C|).(Raw_context.T.context) :=
          (|C|).(Raw_context.T.remove_rec) __t_value (to_key k) in
        let copy
          (__t_value : (|C|).(Raw_context.T.context)) (from : list string)
          (to_ : list string)
          : Lwt.t (Error_monad.tzresult (|C|).(Raw_context.T.context)) :=
          (|C|).(Raw_context.T.copy) __t_value (to_key from) (to_key to_) in
        let fold {A : Set}
          (__t_value : (|C|).(Raw_context.T.context)) (k : list string)
          (init : A)
          (f : (* `Key *) list string + (* `Dir *) list string -> A -> Lwt.t A)
          : Lwt.t A :=
          (|C|).(Raw_context.T.fold) __t_value (to_key k) init
            (fun k => fun acc => f (map_key of_key k) acc) in
        let keys (__t_value : (|C|).(Raw_context.T.context)) (k : list string)
          : Lwt.t (list (list string)) :=
          Error_monad.op_gtpipeeq
            ((|C|).(Raw_context.T.keys) __t_value (to_key k))
            (fun keys => List.map of_key keys) in
        let fold_keys {A : Set}
          (__t_value : (|C|).(Raw_context.T.context)) (k : list string)
          (init : A) (f : list string -> A -> Lwt.t A) : Lwt.t A :=
          (|C|).(Raw_context.T.fold_keys) __t_value (to_key k) init
            (fun k => fun acc => f (of_key k) acc) in
        let project := (|C|).(Raw_context.T.project) in
        let absolute_key (c : (|C|).(Raw_context.T.context)) (k : list string)
          : Raw_context.key :=
          (|C|).(Raw_context.T.absolute_key) c (to_key k) in
        let consume_gas := (|C|).(Raw_context.T.consume_gas) in
        let check_enough_gas := (|C|).(Raw_context.T.check_enough_gas) in
        let description :=
          let description :=
            if (|R|).(Storage_sigs.REGISTER.ghost) then
              Storage_description.create tt
            else
              (|C|).(Raw_context.T.description) in
          Storage_description.register_named_subcontext description
            (|N|).(Storage_sigs.NAME.name) in
        existT (fun _ => _) tt
          {|
            Raw_context.T.mem := mem;
            Raw_context.T.dir_mem := dir_mem;
            Raw_context.T.get := get;
            Raw_context.T.get_option := get_option;
            Raw_context.T.init := init;
            Raw_context.T.set := set;
            Raw_context.T.init_set := init_set;
            Raw_context.T.set_option := set_option;
            Raw_context.T.delete := delete;
            Raw_context.T.remove := remove;
            Raw_context.T.remove_rec := remove_rec;
            Raw_context.T.copy := copy;
            Raw_context.T.fold {_} := fold;
            Raw_context.T.keys := keys;
            Raw_context.T.fold_keys {_} := fold_keys;
            Raw_context.T.project := project;
            Raw_context.T.absolute_key := absolute_key;
            Raw_context.T.consume_gas := consume_gas;
            Raw_context.T.check_enough_gas := check_enough_gas;
            Raw_context.T.description := description
          |} : {_ : unit & Raw_context.T.signature (|C|).(Raw_context.T.t)}).

Definition Make_single_data_storage :=
  fun (R : {_ : unit & REGISTER.signature}) =>
    fun (C : {t : _ & Raw_context.T.signature t}) =>
      fun (N : {_ : unit & NAME.signature}) =>
        fun (V : {t : _ & VALUE.signature t}) =>
          (let t := (|C|).(Raw_context.T.t) in
          let context := t in
          let value := (|V|).(Storage_sigs.VALUE.t) in
          let mem (__t_value : (|C|).(Raw_context.T.context)) : Lwt.t bool :=
            (|C|).(Raw_context.T.mem) __t_value (|N|).(Storage_sigs.NAME.name)
            in
          (* ❌ unhandled_include *)
          let get (__t_value : (|C|).(Raw_context.T.context))
            : Lwt.t (Error_monad.tzresult (|V|).(Storage_sigs.VALUE.t)) :=
            Error_monad.op_gtgteqquestion
              ((|C|).(Raw_context.T.get) __t_value
                (|N|).(Storage_sigs.NAME.name))
              (fun b =>
                let key :=
                  (|C|).(Raw_context.T.absolute_key) __t_value
                    (|N|).(Storage_sigs.NAME.name) in
                Lwt.__return (of_bytes key b)) in
          let get_option (__t_value : (|C|).(Raw_context.T.context))
            : Lwt.t (Error_monad.tzresult (option (|V|).(Storage_sigs.VALUE.t))) :=
            Error_monad.op_gtgteq
              ((|C|).(Raw_context.T.get_option) __t_value
                (|N|).(Storage_sigs.NAME.name))
              (fun function_parameter =>
                match function_parameter with
                | None => Error_monad.return_none
                | Some b =>
                  let key :=
                    (|C|).(Raw_context.T.absolute_key) __t_value
                      (|N|).(Storage_sigs.NAME.name) in
                  match of_bytes key b with
                  | Pervasives.Ok v => Error_monad.return_some v
                  | (Pervasives.Error _) as err => Lwt.__return err
                  end
                end) in
          let init
            (__t_value : (|C|).(Raw_context.T.context))
            (v : (|V|).(Storage_sigs.VALUE.t))
            : Lwt.t (Error_monad.tzresult Raw_context.root_context) :=
            Error_monad.op_gtgteqquestion
              ((|C|).(Raw_context.T.init) __t_value
                (|N|).(Storage_sigs.NAME.name) (to_bytes v))
              (fun __t_value =>
                Error_monad.__return ((|C|).(Raw_context.T.project) __t_value))
            in
          let set
            (__t_value : (|C|).(Raw_context.T.context))
            (v : (|V|).(Storage_sigs.VALUE.t))
            : Lwt.t (Error_monad.tzresult Raw_context.root_context) :=
            Error_monad.op_gtgteqquestion
              ((|C|).(Raw_context.T.set) __t_value
                (|N|).(Storage_sigs.NAME.name) (to_bytes v))
              (fun __t_value =>
                Error_monad.__return ((|C|).(Raw_context.T.project) __t_value))
            in
          let init_set
            (__t_value : (|C|).(Raw_context.T.context))
            (v : (|V|).(Storage_sigs.VALUE.t))
            : Lwt.t Raw_context.root_context :=
            Error_monad.op_gtgteq
              ((|C|).(Raw_context.T.init_set) __t_value
                (|N|).(Storage_sigs.NAME.name) (to_bytes v))
              (fun __t_value =>
                Lwt.__return ((|C|).(Raw_context.T.project) __t_value)) in
          let set_option
            (__t_value : (|C|).(Raw_context.T.context))
            (v : option (|V|).(Storage_sigs.VALUE.t))
            : Lwt.t Raw_context.root_context :=
            Error_monad.op_gtgteq
              ((|C|).(Raw_context.T.set_option) __t_value
                (|N|).(Storage_sigs.NAME.name) (Option.map to_bytes v))
              (fun __t_value =>
                Lwt.__return ((|C|).(Raw_context.T.project) __t_value)) in
          let remove (__t_value : (|C|).(Raw_context.T.context))
            : Lwt.t Raw_context.root_context :=
            Error_monad.op_gtgteq
              ((|C|).(Raw_context.T.remove) __t_value
                (|N|).(Storage_sigs.NAME.name))
              (fun __t_value =>
                Lwt.__return ((|C|).(Raw_context.T.project) __t_value)) in
          let delete (__t_value : (|C|).(Raw_context.T.context))
            : Lwt.t (Error_monad.tzresult Raw_context.root_context) :=
            Error_monad.op_gtgteqquestion
              ((|C|).(Raw_context.T.delete) __t_value
                (|N|).(Storage_sigs.NAME.name))
              (fun __t_value =>
                Error_monad.__return ((|C|).(Raw_context.T.project) __t_value))
            in
          (* ❌ top_level_evaluation *)
          existT (fun _ => _) tt
            {|
              Storage_sigs.Single_data_storage.mem := mem;
              Storage_sigs.Single_data_storage.get := get;
              Storage_sigs.Single_data_storage.get_option := get_option;
              Storage_sigs.Single_data_storage.init := init;
              Storage_sigs.Single_data_storage.set := set;
              Storage_sigs.Single_data_storage.init_set := init_set;
              Storage_sigs.Single_data_storage.set_option := set_option;
              Storage_sigs.Single_data_storage.delete := delete;
              Storage_sigs.Single_data_storage.remove := remove
            |} :
            {_ : unit &
              Single_data_storage.signature (|C|).(Raw_context.T.t)
                (|V|).(Storage_sigs.VALUE.t)}).

Module INDEX.
  Record signature {t : Set} {ipath : Set -> Set} := {
    t := t;
    path_length : Z;
    to_path : t -> list string -> list string;
    of_path : list string -> option t;
    ipath := ipath;
    args : forall {a : Set}, Storage_description.args a t (ipath a);
  }.
  Arguments signature : clear implicits.
End INDEX.

Definition Pair :=
  fun (I1 : {'[t, ipath] : _ & INDEX.signature t ipath}) =>
    fun (I2 : {'[t, ipath] : _ & INDEX.signature t ipath}) =>
      (let t := (|I1|).(INDEX.t) * (|I2|).(INDEX.t) in
      let path_length :=
        Pervasives.op_plus (|I1|).(INDEX.path_length) (|I2|).(INDEX.path_length)
        in
      let to_path (function_parameter : (|I1|).(INDEX.t) * (|I2|).(INDEX.t))
        : list string -> list string :=
        let '(x, y) := function_parameter in
        fun l => (|I1|).(INDEX.to_path) x ((|I2|).(INDEX.to_path) y l) in
      let of_path (l : list string)
        : option ((|I1|).(INDEX.t) * (|I2|).(INDEX.t)) :=
        match Misc.take (|I1|).(INDEX.path_length) l with
        | None => None
        | Some (l1, l2) =>
          match (((|I1|).(INDEX.of_path) l1), ((|I2|).(INDEX.of_path) l2)) with
          | (Some x, Some y) => Some (x, y)
          | _ => None
          end
        end in
      let ipath (a : Set) := (|I2|).(INDEX.ipath) ((|I1|).(INDEX.ipath) a) in
      let args :=
        Storage_description.Pair (|I1|).(INDEX.args) (|I2|).(INDEX.args) in
      existT _ _
        {|
          INDEX.path_length := path_length;
          INDEX.to_path := to_path;
          INDEX.of_path := of_path;
          INDEX.args {_} := args
        |} :
        {ipath : _ &
          INDEX.signature ((|I1|).(INDEX.t) * (|I2|).(INDEX.t)) ipath}).

Definition Make_data_set_storage :=
  fun (C : {t : _ & Raw_context.T.signature t}) =>
    fun (I : {'[t, ipath] : _ & INDEX.signature t ipath}) =>
      (let t := (|C|).(Raw_context.T.t) in
      let context := t in
      let elt := (|I|).(INDEX.t) in
      let inited := MBytes.of_string "inited" in
      let mem (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
        : Lwt.t bool :=
        (|C|).(Raw_context.T.mem) s ((|I|).(INDEX.to_path) i []) in
      let add (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
        : Lwt.t Raw_context.root_context :=
        Error_monad.op_gtgteq
          ((|C|).(Raw_context.T.init_set) s ((|I|).(INDEX.to_path) i []) inited)
          (fun __t_value =>
            Lwt.__return ((|C|).(Raw_context.T.project) __t_value)) in
      let del (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
        : Lwt.t Raw_context.root_context :=
        Error_monad.op_gtgteq
          ((|C|).(Raw_context.T.remove) s ((|I|).(INDEX.to_path) i []))
          (fun __t_value =>
            Lwt.__return ((|C|).(Raw_context.T.project) __t_value)) in
      let set
        (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
        (function_parameter : bool) : Lwt.t Raw_context.root_context :=
        match function_parameter with
        | true => add s i
        | false => del s i
        end in
      let clear (s : (|C|).(Raw_context.T.context))
        : Lwt.t Raw_context.root_context :=
        Error_monad.op_gtgteq ((|C|).(Raw_context.T.remove_rec) s [])
          (fun __t_value =>
            Lwt.__return ((|C|).(Raw_context.T.project) __t_value)) in
      let fold {A : Set}
        (s : (|C|).(Raw_context.T.context)) (init : A)
        (f : (|I|).(INDEX.t) -> A -> Lwt.t A) : Lwt.t A :=
        let fix dig
          (i : (|Compare.Int|).(Compare.S.t)) (path : Raw_context.key) (acc : A)
          {struct i} : Lwt.t A :=
          if (|Compare.Int|).(Compare.S.op_lteq) i 1 then
            (|C|).(Raw_context.T.fold) s path acc
              (fun k =>
                fun acc =>
                  match k with
                  | Dir _ => Lwt.__return acc
                  | Key file =>
                    match (|I|).(INDEX.of_path) file with
                    | None =>
                      (* ❌ Assert instruction is not handled. *)
                      assert false
                    | Some p => f p acc
                    end
                  end)
          else
            (|C|).(Raw_context.T.fold) s path acc
              (fun k =>
                fun acc =>
                  match k with
                  | Dir k => dig (Pervasives.op_minus i 1) k acc
                  | Key _ => Lwt.__return acc
                  end) in
        dig (|I|).(INDEX.path_length) [] init in
      let elements (s : (|C|).(Raw_context.T.context))
        : Lwt.t (list (|I|).(INDEX.t)) :=
        fold s [] (fun p => fun acc => Lwt.__return (cons p acc)) in
      (* ❌ top_level_evaluation *)
      existT (fun _ => _) tt
        {|
          Storage_sigs.Data_set_storage.mem := mem;
          Storage_sigs.Data_set_storage.add := add;
          Storage_sigs.Data_set_storage.del := del;
          Storage_sigs.Data_set_storage.set := set;
          Storage_sigs.Data_set_storage.elements := elements;
          Storage_sigs.Data_set_storage.fold {_} := fold;
          Storage_sigs.Data_set_storage.clear := clear
        |} :
        {_ : unit &
          Data_set_storage.signature (|C|).(Raw_context.T.t) (|I|).(INDEX.t)}).

Definition Make_indexed_data_storage :=
  fun (C : {t : _ & Raw_context.T.signature t}) =>
    fun (I : {'[t, ipath] : _ & INDEX.signature t ipath}) =>
      fun (V : {t : _ & VALUE.signature t}) =>
        (let t := (|C|).(Raw_context.T.t) in
        let context := t in
        let key := (|I|).(INDEX.t) in
        let value := (|V|).(Storage_sigs.VALUE.t) in
        (* ❌ unhandled_include *)
        let mem (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          : Lwt.t bool :=
          (|C|).(Raw_context.T.mem) s ((|I|).(INDEX.to_path) i []) in
        let get (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          : Lwt.t (Error_monad.tzresult (|V|).(Storage_sigs.VALUE.t)) :=
          Error_monad.op_gtgteqquestion
            ((|C|).(Raw_context.T.get) s ((|I|).(INDEX.to_path) i []))
            (fun b =>
              let key :=
                (|C|).(Raw_context.T.absolute_key) s
                  ((|I|).(INDEX.to_path) i []) in
              Lwt.__return (of_bytes key b)) in
        let get_option (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          : Lwt.t (Error_monad.tzresult (option (|V|).(Storage_sigs.VALUE.t))) :=
          Error_monad.op_gtgteq
            ((|C|).(Raw_context.T.get_option) s ((|I|).(INDEX.to_path) i []))
            (fun function_parameter =>
              match function_parameter with
              | None => Error_monad.return_none
              | Some b =>
                let key :=
                  (|C|).(Raw_context.T.absolute_key) s
                    ((|I|).(INDEX.to_path) i []) in
                match of_bytes key b with
                | Pervasives.Ok v => Error_monad.return_some v
                | (Pervasives.Error _) as err => Lwt.__return err
                end
              end) in
        let set
          (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          (v : (|V|).(Storage_sigs.VALUE.t))
          : Lwt.t (Error_monad.tzresult Raw_context.root_context) :=
          Error_monad.op_gtgteqquestion
            ((|C|).(Raw_context.T.set) s ((|I|).(INDEX.to_path) i [])
              (to_bytes v))
            (fun __t_value =>
              Error_monad.__return ((|C|).(Raw_context.T.project) __t_value)) in
        let init
          (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          (v : (|V|).(Storage_sigs.VALUE.t))
          : Lwt.t (Error_monad.tzresult Raw_context.root_context) :=
          Error_monad.op_gtgteqquestion
            ((|C|).(Raw_context.T.init) s ((|I|).(INDEX.to_path) i [])
              (to_bytes v))
            (fun __t_value =>
              Error_monad.__return ((|C|).(Raw_context.T.project) __t_value)) in
        let init_set
          (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          (v : (|V|).(Storage_sigs.VALUE.t)) : Lwt.t Raw_context.root_context :=
          Error_monad.op_gtgteq
            ((|C|).(Raw_context.T.init_set) s ((|I|).(INDEX.to_path) i [])
              (to_bytes v))
            (fun __t_value =>
              Lwt.__return ((|C|).(Raw_context.T.project) __t_value)) in
        let set_option
          (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          (v : option (|V|).(Storage_sigs.VALUE.t))
          : Lwt.t Raw_context.root_context :=
          Error_monad.op_gtgteq
            ((|C|).(Raw_context.T.set_option) s ((|I|).(INDEX.to_path) i [])
              (Option.map to_bytes v))
            (fun __t_value =>
              Lwt.__return ((|C|).(Raw_context.T.project) __t_value)) in
        let remove (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          : Lwt.t Raw_context.root_context :=
          Error_monad.op_gtgteq
            ((|C|).(Raw_context.T.remove) s ((|I|).(INDEX.to_path) i []))
            (fun __t_value =>
              Lwt.__return ((|C|).(Raw_context.T.project) __t_value)) in
        let delete (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          : Lwt.t (Error_monad.tzresult Raw_context.root_context) :=
          Error_monad.op_gtgteqquestion
            ((|C|).(Raw_context.T.delete) s ((|I|).(INDEX.to_path) i []))
            (fun __t_value =>
              Error_monad.__return ((|C|).(Raw_context.T.project) __t_value)) in
        let clear (s : (|C|).(Raw_context.T.context))
          : Lwt.t Raw_context.root_context :=
          Error_monad.op_gtgteq ((|C|).(Raw_context.T.remove_rec) s [])
            (fun __t_value =>
              Lwt.__return ((|C|).(Raw_context.T.project) __t_value)) in
        let fold_keys {A : Set}
          (s : (|C|).(Raw_context.T.context)) (init : A)
          (f : (|I|).(INDEX.t) -> A -> Lwt.t A) : Lwt.t A :=
          let fix dig
            (i : (|Compare.Int|).(Compare.S.t)) (path : Raw_context.key)
            (acc : A) {struct i} : Lwt.t A :=
            if (|Compare.Int|).(Compare.S.op_lteq) i 1 then
              (|C|).(Raw_context.T.fold) s path acc
                (fun k =>
                  fun acc =>
                    match k with
                    | Dir _ => Lwt.__return acc
                    | Key file =>
                      match (|I|).(INDEX.of_path) file with
                      | None =>
                        (* ❌ Assert instruction is not handled. *)
                        assert false
                      | Some path => f path acc
                      end
                    end)
            else
              (|C|).(Raw_context.T.fold) s path acc
                (fun k =>
                  fun acc =>
                    match k with
                    | Dir k => dig (Pervasives.op_minus i 1) k acc
                    | Key _ => Lwt.__return acc
                    end) in
          dig (|I|).(INDEX.path_length) [] init in
        let fold {A : Set}
          (s : (|C|).(Raw_context.T.context)) (init : A)
          (f : (|I|).(INDEX.t) -> (|V|).(Storage_sigs.VALUE.t) -> A -> Lwt.t A)
          : Lwt.t A :=
          let f (path : (|I|).(INDEX.t)) (acc : A) : Lwt.t A :=
            Error_monad.op_gtgteq (get s path)
              (fun function_parameter =>
                match function_parameter with
                | Pervasives.Error _ => Lwt.__return acc
                | Pervasives.Ok v => f path v acc
                end) in
          fold_keys s init f in
        let bindings (s : (|C|).(Raw_context.T.context))
          : Lwt.t (list ((|I|).(INDEX.t) * (|V|).(Storage_sigs.VALUE.t))) :=
          fold s []
            (fun p => fun v => fun acc => Lwt.__return (cons (p, v) acc)) in
        let keys (s : (|C|).(Raw_context.T.context))
          : Lwt.t (list (|I|).(INDEX.t)) :=
          fold_keys s [] (fun p => fun acc => Lwt.__return (cons p acc)) in
        (* ❌ top_level_evaluation *)
        existT (fun _ => _) tt
          {|
            Storage_sigs.Indexed_data_storage.mem := mem;
            Storage_sigs.Indexed_data_storage.get := get;
            Storage_sigs.Indexed_data_storage.get_option := get_option;
            Storage_sigs.Indexed_data_storage.set := set;
            Storage_sigs.Indexed_data_storage.init := init;
            Storage_sigs.Indexed_data_storage.init_set := init_set;
            Storage_sigs.Indexed_data_storage.set_option := set_option;
            Storage_sigs.Indexed_data_storage.delete := delete;
            Storage_sigs.Indexed_data_storage.remove := remove;
            Storage_sigs.Indexed_data_storage.clear := clear;
            Storage_sigs.Indexed_data_storage.keys := keys;
            Storage_sigs.Indexed_data_storage.bindings := bindings;
            Storage_sigs.Indexed_data_storage.fold {_} := fold;
            Storage_sigs.Indexed_data_storage.fold_keys {_} := fold_keys
          |} :
          {_ : unit &
            Indexed_data_storage.signature (|C|).(Raw_context.T.t)
              (|I|).(INDEX.t) (|V|).(Storage_sigs.VALUE.t)}).

Definition Make_indexed_carbonated_data_storage :=
  fun (C : {t : _ & Raw_context.T.signature t}) =>
    fun (I : {'[t, ipath] : _ & INDEX.signature t ipath}) =>
      fun (V : {t : _ & VALUE.signature t}) =>
        (let t := (|C|).(Raw_context.T.t) in
        let context := t in
        let key := (|I|).(INDEX.t) in
        let value := (|V|).(Storage_sigs.VALUE.t) in
        (* ❌ unhandled_include *)
        let data_key (i : (|I|).(INDEX.t)) : list string :=
          (|I|).(INDEX.to_path) i [ data_name ] in
        let len_key (i : (|I|).(INDEX.t)) : list string :=
          (|I|).(INDEX.to_path) i [ len_name ] in
        let consume_mem_gas (c : (|C|).(Raw_context.T.context))
          : Lwt.t (Error_monad.tzresult (|C|).(Raw_context.T.context)) :=
          Lwt.__return
            ((|C|).(Raw_context.T.consume_gas) c
              (Gas_limit_repr.read_bytes_cost Z.zero)) in
        let existing_size
          (c : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          : Lwt.t (Error_monad.tzresult (Z * bool)) :=
          Error_monad.op_gtgteq ((|C|).(Raw_context.T.get_option) c (len_key i))
            (fun function_parameter =>
              match function_parameter with
              | None => Error_monad.__return (0, false)
              | Some len =>
                Error_monad.op_gtgteqquestion (decode_len_value (len_key i) len)
                  (fun len => Error_monad.__return (len, true))
              end) in
        let consume_read_gas
          (get :
            (|C|).(Raw_context.T.context) -> list string ->
            Lwt.t (Error_monad.tzresult MBytes.t))
          (c : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          : Lwt.t (Error_monad.tzresult (|C|).(Raw_context.T.context)) :=
          Error_monad.op_gtgteqquestion (get c (len_key i))
            (fun len =>
              Error_monad.op_gtgteqquestion (decode_len_value (len_key i) len)
                (fun len =>
                  Lwt.__return
                    ((|C|).(Raw_context.T.consume_gas) c
                      (Gas_limit_repr.read_bytes_cost (Z.of_int len))))) in
        let consume_serialize_write_gas {A : Set}
          (set :
            (|C|).(Raw_context.T.context) -> list string -> MBytes.t ->
            Lwt.t (Error_monad.tzresult A)) (c : (|C|).(Raw_context.T.context))
          (i : (|I|).(INDEX.t)) (v : (|V|).(Storage_sigs.VALUE.t))
          : Lwt.t (Error_monad.tzresult (A * MBytes.t)) :=
          let __bytes_value := to_bytes v in
          let len := MBytes.length __bytes_value in
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              ((|C|).(Raw_context.T.consume_gas) c
                (Gas_limit_repr.alloc_mbytes_cost len)))
            (fun c =>
              Error_monad.op_gtgteqquestion
                (Lwt.__return
                  ((|C|).(Raw_context.T.consume_gas) c
                    (Gas_limit_repr.write_bytes_cost (Z.of_int len))))
                (fun c =>
                  Error_monad.op_gtgteqquestion
                    (set c (len_key i) (encode_len_value __bytes_value))
                    (fun c => Error_monad.__return (c, __bytes_value)))) in
        let consume_remove_gas {A : Set}
          (del :
            (|C|).(Raw_context.T.context) -> list string ->
            Lwt.t (Error_monad.tzresult A)) (c : (|C|).(Raw_context.T.context))
          (i : (|I|).(INDEX.t)) : Lwt.t (Error_monad.tzresult A) :=
          Error_monad.op_gtgteqquestion
            (Lwt.__return
              ((|C|).(Raw_context.T.consume_gas) c
                (Gas_limit_repr.write_bytes_cost Z.zero)))
            (fun c => del c (len_key i)) in
        let mem (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          : Lwt.t (Error_monad.tzresult (Raw_context.root_context * bool)) :=
          Error_monad.op_gtgteqquestion (consume_mem_gas s)
            (fun s =>
              Error_monad.op_gtgteq ((|C|).(Raw_context.T.mem) s (data_key i))
                (fun __exists =>
                  Error_monad.__return
                    (((|C|).(Raw_context.T.project) s), __exists))) in
        let get (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          : Lwt.t
            (Error_monad.tzresult
              (Raw_context.root_context * (|V|).(Storage_sigs.VALUE.t))) :=
          Error_monad.op_gtgteqquestion
            (consume_read_gas (|C|).(Raw_context.T.get) s i)
            (fun s =>
              Error_monad.op_gtgteqquestion
                ((|C|).(Raw_context.T.get) s (data_key i))
                (fun b =>
                  let key := (|C|).(Raw_context.T.absolute_key) s (data_key i)
                    in
                  Error_monad.op_gtgteqquestion (Lwt.__return (of_bytes key b))
                    (fun v =>
                      Error_monad.__return
                        (((|C|).(Raw_context.T.project) s), v)))) in
        let get_option (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          : Lwt.t
            (Error_monad.tzresult
              (Raw_context.root_context * option (|V|).(Storage_sigs.VALUE.t))) :=
          Error_monad.op_gtgteqquestion (consume_mem_gas s)
            (fun s =>
              Error_monad.op_gtgteq ((|C|).(Raw_context.T.mem) s (data_key i))
                (fun __exists =>
                  if __exists then
                    Error_monad.op_gtgteqquestion (get s i)
                      (fun function_parameter =>
                        let '(s, v) := function_parameter in
                        Error_monad.__return (s, (Some v)))
                  else
                    Error_monad.__return
                      (((|C|).(Raw_context.T.project) s), None))) in
        let set
          (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          (v : (|V|).(Storage_sigs.VALUE.t))
          : Lwt.t (Error_monad.tzresult (Raw_context.root_context * Z)) :=
          Error_monad.op_gtgteqquestion (existing_size s i)
            (fun function_parameter =>
              let '(prev_size, _) := function_parameter in
              Error_monad.op_gtgteqquestion
                (consume_serialize_write_gas (|C|).(Raw_context.T.set) s i v)
                (fun function_parameter =>
                  let '(s, __bytes_value) := function_parameter in
                  Error_monad.op_gtgteqquestion
                    ((|C|).(Raw_context.T.set) s (data_key i) __bytes_value)
                    (fun __t_value =>
                      let size_diff :=
                        Pervasives.op_minus (MBytes.length __bytes_value)
                          prev_size in
                      Error_monad.__return
                        (((|C|).(Raw_context.T.project) __t_value), size_diff))))
          in
        let init
          (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          (v : (|V|).(Storage_sigs.VALUE.t))
          : Lwt.t (Error_monad.tzresult (Raw_context.root_context * Z)) :=
          Error_monad.op_gtgteqquestion
            (consume_serialize_write_gas (|C|).(Raw_context.T.init) s i v)
            (fun function_parameter =>
              let '(s, __bytes_value) := function_parameter in
              Error_monad.op_gtgteqquestion
                ((|C|).(Raw_context.T.init) s (data_key i) __bytes_value)
                (fun __t_value =>
                  let size := MBytes.length __bytes_value in
                  Error_monad.__return
                    (((|C|).(Raw_context.T.project) __t_value), size))) in
        let init_set
          (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          (v : (|V|).(Storage_sigs.VALUE.t))
          : Lwt.t (Error_monad.tzresult (Raw_context.root_context * Z * bool)) :=
          let init_set
            (s : (|C|).(Raw_context.T.context)) (i : Raw_context.key)
            (v : Raw_context.value)
            : Lwt.t (Error_monad.tzresult (|C|).(Raw_context.T.context)) :=
            Error_monad.op_gtgteq ((|C|).(Raw_context.T.init_set) s i v)
              Error_monad.__return in
          Error_monad.op_gtgteqquestion (existing_size s i)
            (fun function_parameter =>
              let '(prev_size, existed) := function_parameter in
              Error_monad.op_gtgteqquestion
                (consume_serialize_write_gas init_set s i v)
                (fun function_parameter =>
                  let '(s, __bytes_value) := function_parameter in
                  Error_monad.op_gtgteqquestion
                    (init_set s (data_key i) __bytes_value)
                    (fun __t_value =>
                      let size_diff :=
                        Pervasives.op_minus (MBytes.length __bytes_value)
                          prev_size in
                      Error_monad.__return
                        (((|C|).(Raw_context.T.project) __t_value), size_diff,
                          existed)))) in
        let remove (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          : Lwt.t (Error_monad.tzresult (Raw_context.root_context * Z * bool)) :=
          let remove (s : (|C|).(Raw_context.T.context)) (i : Raw_context.key)
            : Lwt.t (Error_monad.tzresult (|C|).(Raw_context.T.context)) :=
            Error_monad.op_gtgteq ((|C|).(Raw_context.T.remove) s i)
              Error_monad.__return in
          Error_monad.op_gtgteqquestion (existing_size s i)
            (fun function_parameter =>
              let '(prev_size, existed) := function_parameter in
              Error_monad.op_gtgteqquestion (consume_remove_gas remove s i)
                (fun s =>
                  Error_monad.op_gtgteqquestion (remove s (data_key i))
                    (fun __t_value =>
                      Error_monad.__return
                        (((|C|).(Raw_context.T.project) __t_value), prev_size,
                          existed)))) in
        let delete (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          : Lwt.t (Error_monad.tzresult (Raw_context.root_context * Z)) :=
          Error_monad.op_gtgteqquestion (existing_size s i)
            (fun function_parameter =>
              let '(prev_size, _) := function_parameter in
              Error_monad.op_gtgteqquestion
                (consume_remove_gas (|C|).(Raw_context.T.delete) s i)
                (fun s =>
                  Error_monad.op_gtgteqquestion
                    ((|C|).(Raw_context.T.delete) s (data_key i))
                    (fun __t_value =>
                      Error_monad.__return
                        (((|C|).(Raw_context.T.project) __t_value), prev_size))))
          in
        let set_option
          (s : (|C|).(Raw_context.T.context)) (i : (|I|).(INDEX.t))
          (v : option (|V|).(Storage_sigs.VALUE.t))
          : Lwt.t (Error_monad.tzresult (Raw_context.root_context * Z * bool)) :=
          match v with
          | None => remove s i
          | Some v => init_set s i v
          end in
        let fold_keys_unaccounted {A : Set}
          (s : (|C|).(Raw_context.T.context)) (init : A)
          (f : (|I|).(INDEX.t) -> A -> Lwt.t A) : Lwt.t A :=
          let fix dig
            (i : (|Compare.Int|).(Compare.S.t)) (path : Raw_context.key)
            (acc : A) {struct i} : Lwt.t A :=
            if (|Compare.Int|).(Compare.S.op_lteq) i 0 then
              (|C|).(Raw_context.T.fold) s path acc
                (fun k =>
                  fun acc =>
                    match k with
                    | Dir _ => Lwt.__return acc
                    | Key file =>
                      match
                        ((List.rev file),
                          match List.rev file with
                          | cons last _ =>
                            (|Compare.String|).(Compare.S.op_eq) last len_name
                          | _ => false
                          end,
                          match List.rev file with
                          | cons last rest =>
                            (|Compare.String|).(Compare.S.op_eq) last data_name
                          | _ => false
                          end) with
                      | (cons last _, true, _) => Lwt.__return acc
                      | (cons last rest, _, true) =>
                        let file := List.rev rest in
                        match (|I|).(INDEX.of_path) file with
                        | None =>
                          (* ❌ Assert instruction is not handled. *)
                          assert false
                        | Some path => f path acc
                        end
                      | (_, _, _) =>
                        (* ❌ Assert instruction is not handled. *)
                        assert false
                      end
                    end)
            else
              (|C|).(Raw_context.T.fold) s path acc
                (fun k =>
                  fun acc =>
                    match k with
                    | Dir k => dig (Pervasives.op_minus i 1) k acc
                    | Key _ => Lwt.__return acc
                    end) in
          dig (|I|).(INDEX.path_length) [] init in
        let keys_unaccounted (s : (|C|).(Raw_context.T.context))
          : Lwt.t (list (|I|).(INDEX.t)) :=
          fold_keys_unaccounted s []
            (fun p => fun acc => Lwt.__return (cons p acc)) in
        (* ❌ top_level_evaluation *)
        existT (fun _ => _) tt
          {|
            Storage_sigs.Single_data_storage.mem := mem;
            Storage_sigs.Single_data_storage.get := get;
            Storage_sigs.Single_data_storage.get_option := get_option;
            Storage_sigs.Single_data_storage.set := set;
            Storage_sigs.Single_data_storage.init := init;
            Storage_sigs.Single_data_storage.init_set := init_set;
            Storage_sigs.Single_data_storage.set_option := set_option;
            Storage_sigs.Single_data_storage.delete := delete;
            Storage_sigs.Single_data_storage.remove := remove
          |} :
          {_ : unit &
            Non_iterable_indexed_carbonated_data_storage.signature
              (|C|).(Raw_context.T.t) (|I|).(INDEX.t)
              (|V|).(Storage_sigs.VALUE.t)}).

Definition Make_indexed_data_snapshotable_storage :=
  fun (C : {t : _ & Raw_context.T.signature t}) =>
    fun (Snapshot_index : {'[t, ipath] : _ & INDEX.signature t ipath}) =>
      fun (I : {'[t, ipath] : _ & INDEX.signature t ipath}) =>
        fun (V : {t : _ & VALUE.signature t}) =>
          (let snapshot := (|Snapshot_index|).(INDEX.t) in
          let data_name := [ "current" ] in
          let snapshot_name := [ "snapshot" ] in
          let C_data :=
            ((Make_subcontext
              (existT (fun _ => _) tt
                {|
                  Storage_sigs.REGISTER.ghost :=
                    (|Registered|).(Storage_sigs.REGISTER.ghost)
                |}))
              (existT _ _
                {|
                  Raw_context.T.mem := (|C|).(Raw_context.T.mem);
                  Raw_context.T.dir_mem := (|C|).(Raw_context.T.dir_mem);
                  Raw_context.T.get := (|C|).(Raw_context.T.get);
                  Raw_context.T.get_option := (|C|).(Raw_context.T.get_option);
                  Raw_context.T.init := (|C|).(Raw_context.T.init);
                  Raw_context.T.set := (|C|).(Raw_context.T.set);
                  Raw_context.T.init_set := (|C|).(Raw_context.T.init_set);
                  Raw_context.T.set_option := (|C|).(Raw_context.T.set_option);
                  Raw_context.T.delete := (|C|).(Raw_context.T.delete);
                  Raw_context.T.remove := (|C|).(Raw_context.T.remove);
                  Raw_context.T.remove_rec := (|C|).(Raw_context.T.remove_rec);
                  Raw_context.T.copy := (|C|).(Raw_context.T.copy);
                  Raw_context.T.fold {_} := (|C|).(Raw_context.T.fold);
                  Raw_context.T.keys := (|C|).(Raw_context.T.keys);
                  Raw_context.T.fold_keys {_} := (|C|).(Raw_context.T.fold_keys);
                  Raw_context.T.project := (|C|).(Raw_context.T.project);
                  Raw_context.T.absolute_key :=
                    (|C|).(Raw_context.T.absolute_key);
                  Raw_context.T.consume_gas := (|C|).(Raw_context.T.consume_gas);
                  Raw_context.T.check_enough_gas :=
                    (|C|).(Raw_context.T.check_enough_gas);
                  Raw_context.T.description := (|C|).(Raw_context.T.description)
                |}))
              (let name := data_name in
              existT (fun _ => _) tt
                {|
                  Storage_sigs.NAME.name := name
                |}) in
          let C_snapshot :=
            ((Make_subcontext
              (existT (fun _ => _) tt
                {|
                  Storage_sigs.REGISTER.ghost :=
                    (|Registered|).(Storage_sigs.REGISTER.ghost)
                |}))
              (existT _ _
                {|
                  Raw_context.T.mem := (|C|).(Raw_context.T.mem);
                  Raw_context.T.dir_mem := (|C|).(Raw_context.T.dir_mem);
                  Raw_context.T.get := (|C|).(Raw_context.T.get);
                  Raw_context.T.get_option := (|C|).(Raw_context.T.get_option);
                  Raw_context.T.init := (|C|).(Raw_context.T.init);
                  Raw_context.T.set := (|C|).(Raw_context.T.set);
                  Raw_context.T.init_set := (|C|).(Raw_context.T.init_set);
                  Raw_context.T.set_option := (|C|).(Raw_context.T.set_option);
                  Raw_context.T.delete := (|C|).(Raw_context.T.delete);
                  Raw_context.T.remove := (|C|).(Raw_context.T.remove);
                  Raw_context.T.remove_rec := (|C|).(Raw_context.T.remove_rec);
                  Raw_context.T.copy := (|C|).(Raw_context.T.copy);
                  Raw_context.T.fold {_} := (|C|).(Raw_context.T.fold);
                  Raw_context.T.keys := (|C|).(Raw_context.T.keys);
                  Raw_context.T.fold_keys {_} := (|C|).(Raw_context.T.fold_keys);
                  Raw_context.T.project := (|C|).(Raw_context.T.project);
                  Raw_context.T.absolute_key :=
                    (|C|).(Raw_context.T.absolute_key);
                  Raw_context.T.consume_gas := (|C|).(Raw_context.T.consume_gas);
                  Raw_context.T.check_enough_gas :=
                    (|C|).(Raw_context.T.check_enough_gas);
                  Raw_context.T.description := (|C|).(Raw_context.T.description)
                |}))
              (let name := snapshot_name in
              existT (fun _ => _) tt
                {|
                  Storage_sigs.NAME.name := name
                |}) in
          (* ❌ unhandled_include *)
          let Snapshot :=
            ((Make_indexed_data_storage
              (existT _ _
                {|
                  Raw_context.T.mem := (|C_snapshot|).(Raw_context.T.mem);
                  Raw_context.T.dir_mem :=
                    (|C_snapshot|).(Raw_context.T.dir_mem);
                  Raw_context.T.get := (|C_snapshot|).(Raw_context.T.get);
                  Raw_context.T.get_option :=
                    (|C_snapshot|).(Raw_context.T.get_option);
                  Raw_context.T.init := (|C_snapshot|).(Raw_context.T.init);
                  Raw_context.T.set := (|C_snapshot|).(Raw_context.T.set);
                  Raw_context.T.init_set :=
                    (|C_snapshot|).(Raw_context.T.init_set);
                  Raw_context.T.set_option :=
                    (|C_snapshot|).(Raw_context.T.set_option);
                  Raw_context.T.delete := (|C_snapshot|).(Raw_context.T.delete);
                  Raw_context.T.remove := (|C_snapshot|).(Raw_context.T.remove);
                  Raw_context.T.remove_rec :=
                    (|C_snapshot|).(Raw_context.T.remove_rec);
                  Raw_context.T.copy := (|C_snapshot|).(Raw_context.T.copy);
                  Raw_context.T.fold {_} := (|C_snapshot|).(Raw_context.T.fold);
                  Raw_context.T.keys := (|C_snapshot|).(Raw_context.T.keys);
                  Raw_context.T.fold_keys {_} :=
                    (|C_snapshot|).(Raw_context.T.fold_keys);
                  Raw_context.T.project :=
                    (|C_snapshot|).(Raw_context.T.project);
                  Raw_context.T.absolute_key :=
                    (|C_snapshot|).(Raw_context.T.absolute_key);
                  Raw_context.T.consume_gas :=
                    (|C_snapshot|).(Raw_context.T.consume_gas);
                  Raw_context.T.check_enough_gas :=
                    (|C_snapshot|).(Raw_context.T.check_enough_gas);
                  Raw_context.T.description :=
                    (|C_snapshot|).(Raw_context.T.description)
                |}))
              ((Pair
                (existT _ [_, _]
                  {|
                    INDEX.path_length := (|Snapshot_index|).(INDEX.path_length);
                    INDEX.to_path := (|Snapshot_index|).(INDEX.to_path);
                    INDEX.of_path := (|Snapshot_index|).(INDEX.of_path);
                    INDEX.args {_} := (|Snapshot_index|).(INDEX.args)
                  |}))
                (existT _ [_, _]
                  {|
                    INDEX.path_length := (|I|).(INDEX.path_length);
                    INDEX.to_path := (|I|).(INDEX.to_path);
                    INDEX.of_path := (|I|).(INDEX.of_path);
                    INDEX.args {_} := (|I|).(INDEX.args)
                  |})))
              (existT _ _
                {|
                  Storage_sigs.VALUE.encoding :=
                    (|V|).(Storage_sigs.VALUE.encoding)
                |}) in
          let snapshot_path (id : (|Snapshot_index|).(INDEX.t)) : list string :=
            Pervasives.op_at snapshot_name
              ((|Snapshot_index|).(INDEX.to_path) id []) in
          let snapshot_exists
            (s : (|C|).(Raw_context.T.context))
            (id : (|Snapshot_index|).(INDEX.t)) : Lwt.t bool :=
            (|C|).(Raw_context.T.dir_mem) s (snapshot_path id) in
          let __snapshot_value
            (s : (|C|).(Raw_context.T.context))
            (id : (|Snapshot_index|).(INDEX.t))
            : Lwt.t (Error_monad.tzresult Raw_context.root_context) :=
            Error_monad.op_gtgteqquestion
              ((|C|).(Raw_context.T.copy) s data_name (snapshot_path id))
              (fun __t_value =>
                Error_monad.__return ((|C|).(Raw_context.T.project) __t_value))
            in
          let delete_snapshot
            (s : (|C|).(Raw_context.T.context))
            (id : (|Snapshot_index|).(INDEX.t))
            : Lwt.t Raw_context.root_context :=
            Error_monad.op_gtgteq
              ((|C|).(Raw_context.T.remove_rec) s (snapshot_path id))
              (fun __t_value =>
                Lwt.__return ((|C|).(Raw_context.T.project) __t_value)) in
          existT (fun _ => _) tt
            {|
              Storage_sigs.Indexed_data_snapshotable_storage.mem := mem;
              Storage_sigs.Indexed_data_snapshotable_storage.get := get;
              Storage_sigs.Indexed_data_snapshotable_storage.get_option :=
                get_option;
              Storage_sigs.Indexed_data_snapshotable_storage.set := set;
              Storage_sigs.Indexed_data_snapshotable_storage.init := init;
              Storage_sigs.Indexed_data_snapshotable_storage.init_set :=
                init_set;
              Storage_sigs.Indexed_data_snapshotable_storage.set_option :=
                set_option;
              Storage_sigs.Indexed_data_snapshotable_storage.delete := delete;
              Storage_sigs.Indexed_data_snapshotable_storage.remove := remove;
              Storage_sigs.Indexed_data_snapshotable_storage.clear := clear;
              Storage_sigs.Indexed_data_snapshotable_storage.keys := keys;
              Storage_sigs.Indexed_data_snapshotable_storage.bindings :=
                bindings;
              Storage_sigs.Indexed_data_snapshotable_storage.fold {_} := fold;
              Storage_sigs.Indexed_data_snapshotable_storage.fold_keys {_} :=
                fold_keys;
              Storage_sigs.Indexed_data_snapshotable_storage.snapshot_exists :=
                snapshot_exists;
              Storage_sigs.Indexed_data_snapshotable_storage.__snapshot_value :=
                __snapshot_value;
              Storage_sigs.Indexed_data_snapshotable_storage.delete_snapshot :=
                delete_snapshot
            |} :
            {_ : unit &
              Indexed_data_snapshotable_storage.signature
                (|Snapshot_index|).(INDEX.t) (|I|).(INDEX.t)
                (|C|).(Raw_context.T.t) (|V|).(Storage_sigs.VALUE.t)}).

Definition Make_indexed_subcontext :=
  fun (C : {t : _ & Raw_context.T.signature t}) =>
    fun (I : {'[t, ipath] : _ & INDEX.signature t ipath}) =>
      (let t := (|C|).(Raw_context.T.t) in
      let context := t in
      let key := (|I|).(INDEX.t) in
      let ipath (a : Set) := (|I|).(INDEX.ipath) a in
      let clear (__t_value : (|C|).(Raw_context.T.context))
        : Lwt.t Raw_context.root_context :=
        Error_monad.op_gtgteq ((|C|).(Raw_context.T.remove_rec) __t_value [])
          (fun __t_value =>
            Lwt.__return ((|C|).(Raw_context.T.project) __t_value)) in
      let fold_keys {A : Set}
        (__t_value : (|C|).(Raw_context.T.context)) (init : A)
        (f : (|I|).(INDEX.t) -> A -> Lwt.t A) : Lwt.t A :=
        let fix dig
          (i : (|Compare.Int|).(Compare.S.t)) (path : Raw_context.key) (acc : A)
          {struct i} : Lwt.t A :=
          if (|Compare.Int|).(Compare.S.op_lteq) i 0 then
            match (|I|).(INDEX.of_path) path with
            | None =>
              (* ❌ Assert instruction is not handled. *)
              assert false
            | Some path => f path acc
            end
          else
            (|C|).(Raw_context.T.fold) __t_value path acc
              (fun k =>
                fun acc =>
                  match k with
                  | Dir k => dig (Pervasives.op_minus i 1) k acc
                  | Key _ => Lwt.__return acc
                  end) in
        dig (|I|).(INDEX.path_length) [] init in
      let keys (__t_value : (|C|).(Raw_context.T.context))
        : Lwt.t (list (|I|).(INDEX.t)) :=
        fold_keys __t_value [] (fun i => fun acc => Lwt.__return (cons i acc))
        in
      let __list_value
        (__t_value : (|C|).(Raw_context.T.context)) (k : Raw_context.key)
        : Lwt.t (list ((* `Dir *) Raw_context.key + (* `Key *) Raw_context.key)) :=
        (|C|).(Raw_context.T.fold) __t_value k []
          (fun k => fun acc => Lwt.__return (cons k acc)) in
      let remove_rec
        (__t_value : (|C|).(Raw_context.T.context)) (k : (|I|).(INDEX.t))
        : Lwt.t (|C|).(Raw_context.T.context) :=
        (|C|).(Raw_context.T.remove_rec) __t_value ((|I|).(INDEX.to_path) k [])
        in
      let copy
        (__t_value : (|C|).(Raw_context.T.context)) (from : (|I|).(INDEX.t))
        (to_ : (|I|).(INDEX.t))
        : Lwt.t (Error_monad.tzresult (|C|).(Raw_context.T.context)) :=
        (|C|).(Raw_context.T.copy) __t_value ((|I|).(INDEX.to_path) from [])
          ((|I|).(INDEX.to_path) to_ []) in
      let description :=
        Storage_description.register_indexed_subcontext
          (|C|).(Raw_context.T.description)
          (fun c => Error_monad.op_gtgteq (keys c) Error_monad.__return)
          (|I|).(INDEX.args) in
      let unpack := Storage_description.unpack (|I|).(INDEX.args) in
      let pack := Storage_description.pack (|I|).(INDEX.args) in
      let Raw_context :=
        (* ❌ The signature name of this module could not be found *)
        first_class_module_value_of_unknown_signature in
      let resolve
        (__t_value : (|C|).(Raw_context.T.context)) (prefix : list string)
        : Lwt.t (list (|I|).(INDEX.t)) :=
        let fix loop
          (i : (|Compare.Int|).(Compare.S.t)) (prefix : Raw_context.key)
          (function_parameter : list string) {struct i}
          : Lwt.t (list (|I|).(INDEX.t)) :=
          match
            (function_parameter,
              match function_parameter with
              | [] =>
                (|Compare.Int|).(Compare.S.op_eq) i (|I|).(INDEX.path_length)
              | _ => false
              end,
              match function_parameter with
              | cons d [] =>
                (|Compare.Int|).(Compare.S.op_eq) i
                  (Pervasives.op_minus (|I|).(INDEX.path_length) 1)
              | _ => false
              end) with
          | ([], true, _) =>
            match (|I|).(INDEX.of_path) prefix with
            | None =>
              (* ❌ Assert instruction is not handled. *)
              assert false
            | Some path => Lwt.__return [ path ]
            end
          | ([], _, _) =>
            Error_monad.op_gtgteq (__list_value __t_value prefix)
              (fun prefixes =>
                Error_monad.op_gtpipeeq
                  (Lwt_list.map_s
                    (fun function_parameter =>
                      let 'Key prefix | Dir prefix := function_parameter in
                      loop (Pervasives.op_plus i 1) prefix []) prefixes)
                  List.flatten)
          | (cons d [], _, true) =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            (* ❌ instruction_sequence ";" *)
            Error_monad.op_gtgteq (__list_value __t_value prefix)
              (fun prefixes =>
                Error_monad.op_gtpipeeq
                  (Lwt_list.map_s
                    (fun function_parameter =>
                      let 'Key prefix | Dir prefix := function_parameter in
                      match Misc.remove_prefix d (List.hd (List.rev prefix))
                        with
                      | None => Lwt.return_nil
                      | Some _ => loop (Pervasives.op_plus i 1) prefix []
                      end) prefixes) List.flatten)
          | (cons "" ds, _, _) =>
            Error_monad.op_gtgteq (__list_value __t_value prefix)
              (fun prefixes =>
                Error_monad.op_gtpipeeq
                  (Lwt_list.map_s
                    (fun function_parameter =>
                      let 'Key prefix | Dir prefix := function_parameter in
                      loop (Pervasives.op_plus i 1) prefix ds) prefixes)
                  List.flatten)
          | (cons d ds, _, _) =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            (* ❌ instruction_sequence ";" *)
            Error_monad.op_gtgteq
              ((|C|).(Raw_context.T.dir_mem) __t_value
                (Pervasives.op_at prefix [ d ]))
              (fun function_parameter =>
                match function_parameter with
                | true =>
                  loop (Pervasives.op_plus i 1) (Pervasives.op_at prefix [ d ])
                    ds
                | false => Lwt.return_nil
                end)
          end in
        loop 0 [] prefix in
      let Make_set :=
        fun (R : {_ : unit & REGISTER.signature}) =>
          fun (N : {_ : unit & NAME.signature}) =>
            (* ❌ The signature name of this module could not be found *)
            first_class_module_value_of_unknown_signature in
      let Make_map :=
        fun (N : {_ : unit & NAME.signature}) =>
          fun (V : {t : _ & VALUE.signature t}) =>
            (* ❌ The signature name of this module could not be found *)
            first_class_module_value_of_unknown_signature in
      let Make_carbonated_map :=
        fun (N : {_ : unit & NAME.signature}) =>
          fun (V : {t : _ & VALUE.signature t}) =>
            (* ❌ The signature name of this module could not be found *)
            first_class_module_value_of_unknown_signature in
      existT (fun _ => _) tt
        {|
          Storage_sigs.Indexed_raw_context.clear := clear;
          Storage_sigs.Indexed_raw_context.fold_keys {_} := fold_keys;
          Storage_sigs.Indexed_raw_context.keys := keys;
          Storage_sigs.Indexed_raw_context.resolve := resolve;
          Storage_sigs.Indexed_raw_context.remove_rec := remove_rec;
          Storage_sigs.Indexed_raw_context.copy := copy
        |} :
        {_ : unit &
          Indexed_raw_context.signature (|C|).(Raw_context.T.t) (|I|).(INDEX.t)
            ((|I|).(INDEX.ipath) a)}).

Definition Wrap_indexed_data_storage :=
  fun (C : {'[t, key, value] : _ & Indexed_data_storage.signature t key value})
    =>
    fun (K : anonymous_signature) =>
      let t := (|C|).(Storage_sigs.Indexed_data_storage.t) in
      let context := (|C|).(Storage_sigs.Indexed_data_storage.t) in
      let key := K.t in
      let value := (|C|).(Storage_sigs.Indexed_data_storage.value) in
      let mem
        (ctxt : (|C|).(Storage_sigs.Indexed_data_storage.context)) (k : K.t)
        : Lwt.t bool :=
        (|C|).(Storage_sigs.Indexed_data_storage.mem) ctxt (K.wrap k) in
      let get
        (ctxt : (|C|).(Storage_sigs.Indexed_data_storage.context)) (k : K.t)
        : Lwt.t
          (Error_monad.tzresult (|C|).(Storage_sigs.Indexed_data_storage.value)) :=
        (|C|).(Storage_sigs.Indexed_data_storage.get) ctxt (K.wrap k) in
      let get_option
        (ctxt : (|C|).(Storage_sigs.Indexed_data_storage.context)) (k : K.t)
        : Lwt.t
          (Error_monad.tzresult
            (option (|C|).(Storage_sigs.Indexed_data_storage.value))) :=
        (|C|).(Storage_sigs.Indexed_data_storage.get_option) ctxt (K.wrap k) in
      let set
        (ctxt : (|C|).(Storage_sigs.Indexed_data_storage.context)) (k : K.t)
        (v : (|C|).(Storage_sigs.Indexed_data_storage.value))
        : Lwt.t (Error_monad.tzresult Raw_context.t) :=
        (|C|).(Storage_sigs.Indexed_data_storage.set) ctxt (K.wrap k) v in
      let init
        (ctxt : (|C|).(Storage_sigs.Indexed_data_storage.context)) (k : K.t)
        (v : (|C|).(Storage_sigs.Indexed_data_storage.value))
        : Lwt.t (Error_monad.tzresult Raw_context.t) :=
        (|C|).(Storage_sigs.Indexed_data_storage.init) ctxt (K.wrap k) v in
      let init_set
        (ctxt : (|C|).(Storage_sigs.Indexed_data_storage.context)) (k : K.t)
        (v : (|C|).(Storage_sigs.Indexed_data_storage.value))
        : Lwt.t Raw_context.t :=
        (|C|).(Storage_sigs.Indexed_data_storage.init_set) ctxt (K.wrap k) v in
      let set_option
        (ctxt : (|C|).(Storage_sigs.Indexed_data_storage.context)) (k : K.t)
        (v : option (|C|).(Storage_sigs.Indexed_data_storage.value))
        : Lwt.t Raw_context.t :=
        (|C|).(Storage_sigs.Indexed_data_storage.set_option) ctxt (K.wrap k) v
        in
      let delete
        (ctxt : (|C|).(Storage_sigs.Indexed_data_storage.context)) (k : K.t)
        : Lwt.t (Error_monad.tzresult Raw_context.t) :=
        (|C|).(Storage_sigs.Indexed_data_storage.delete) ctxt (K.wrap k) in
      let remove
        (ctxt : (|C|).(Storage_sigs.Indexed_data_storage.context)) (k : K.t)
        : Lwt.t Raw_context.t :=
        (|C|).(Storage_sigs.Indexed_data_storage.remove) ctxt (K.wrap k) in
      let clear (ctxt : (|C|).(Storage_sigs.Indexed_data_storage.context))
        : Lwt.t Raw_context.t :=
        (|C|).(Storage_sigs.Indexed_data_storage.clear) ctxt in
      let fold {A : Set}
        (ctxt : (|C|).(Storage_sigs.Indexed_data_storage.context)) (init : A)
        (f :
          K.t -> (|C|).(Storage_sigs.Indexed_data_storage.value) -> A -> Lwt.t A)
        : Lwt.t A :=
        (|C|).(Storage_sigs.Indexed_data_storage.fold) ctxt init
          (fun k =>
            fun v =>
              fun acc =>
                match K.unwrap k with
                | None => Lwt.__return acc
                | Some k => f k v acc
                end) in
      let bindings (s : (|C|).(Storage_sigs.Indexed_data_storage.context))
        : Lwt.t (list (K.t * (|C|).(Storage_sigs.Indexed_data_storage.value))) :=
        fold s [] (fun p => fun v => fun acc => Lwt.__return (cons (p, v) acc))
        in
      let fold_keys {A : Set}
        (s : (|C|).(Storage_sigs.Indexed_data_storage.context)) (init : A)
        (f : K.t -> A -> Lwt.t A) : Lwt.t A :=
        (|C|).(Storage_sigs.Indexed_data_storage.fold_keys) s init
          (fun k =>
            fun acc =>
              match K.unwrap k with
              | None => Lwt.__return acc
              | Some k => f k acc
              end) in
      let keys (s : (|C|).(Storage_sigs.Indexed_data_storage.context))
        : Lwt.t (list K.t) :=
        fold_keys s [] (fun p => fun acc => Lwt.__return (cons p acc)) in
      existT (fun _ => _) tt
        {|
          Storage_sigs.Indexed_data_storage.mem := mem;
          Storage_sigs.Indexed_data_storage.get := get;
          Storage_sigs.Indexed_data_storage.get_option := get_option;
          Storage_sigs.Indexed_data_storage.set := set;
          Storage_sigs.Indexed_data_storage.init := init;
          Storage_sigs.Indexed_data_storage.init_set := init_set;
          Storage_sigs.Indexed_data_storage.set_option := set_option;
          Storage_sigs.Indexed_data_storage.delete := delete;
          Storage_sigs.Indexed_data_storage.remove := remove;
          Storage_sigs.Indexed_data_storage.clear := clear;
          Storage_sigs.Indexed_data_storage.fold {_} := fold;
          Storage_sigs.Indexed_data_storage.bindings := bindings;
          Storage_sigs.Indexed_data_storage.fold_keys {_} := fold_keys;
          Storage_sigs.Indexed_data_storage.keys := keys
        |}.

Storage_functors_mli

  • OCaml size: 105 lines
  • Coq size: 99 lines (-6% compared to OCaml)
storage_functors.mli 7 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Implementation - Typed storage builders. *)

open Storage_sigs

module Registered : REGISTER

module Ghost : REGISTER

module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) :
  Raw_context.T with type t = C.t

module Make_single_data_storage
    (R : REGISTER)
    (C : Raw_context.T)
    (N : NAME)
    (V : VALUE) : Single_data_storage with type t = C.t and type value = V.t

module type INDEX = sig
  type t

  val path_length : int

  val to_path : t -> string list -> string list

  val of_path : string list -> t option

  type 'a ipath

  val args : ('a, t, 'a ipath) Storage_description.args
end

module Pair (I1 : INDEX) (I2 : INDEX) : INDEX with type t = I1.t * I2.t

module Make_data_set_storage (C : Raw_context.T) (I : INDEX) :
  Data_set_storage with type t = C.t and type elt = I.t

module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) :
  Indexed_data_storage
    with type t = C.t
     and type key = I.t
     and type value = V.t

module Make_indexed_carbonated_data_storage
    (C : Raw_context.T)
    (I : INDEX)
    (V : VALUE) :
  Non_iterable_indexed_carbonated_data_storage
    with type t = C.t
     and type key = I.t
     and type value = V.t

module Make_indexed_data_snapshotable_storage
    (C : Raw_context.T)
    (Snapshot : INDEX)
    (I : INDEX)
    (V : VALUE) :
  Indexed_data_snapshotable_storage
    with type t = C.t
     and type snapshot = Snapshot.t
     and type key = I.t
     and type value = V.t

module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) :
  Indexed_raw_context
    with type t = C.t
     and type key = I.t
     and type 'a ipath = 'a I.ipath

module Wrap_indexed_data_storage
    (C : Indexed_data_storage) (K : sig
      type t

      val wrap : t -> C.key

      val unwrap : C.key -> t option
    end) :
  Indexed_data_storage
    with type t = C.t
     and type key = K.t
     and type value = C.value
Storage_functors_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Raw_context.
Require Tezos.Storage_description.
Require Tezos.Storage_sigs.

Parameter Registered : {_ : unit & REGISTER.signature}.

Parameter Ghost : {_ : unit & REGISTER.signature}.

Parameter Make_subcontext :
  forall (R : {_ : unit & REGISTER.signature}),
    (forall (C : {t : _ & Raw_context.T.signature t}),
      (forall (N : {_ : unit & NAME.signature}),
        {_ : unit & Raw_context.T.signature (|C|).(Raw_context.T.t)})).

Parameter Make_single_data_storage :
  forall (R : {_ : unit & REGISTER.signature}),
    (forall (C : {t : _ & Raw_context.T.signature t}),
      (forall (N : {_ : unit & NAME.signature}),
        (forall (V : {t : _ & VALUE.signature t}),
          {_ : unit &
            Single_data_storage.signature (|C|).(Raw_context.T.t)
              (|V|).(Storage_sigs.VALUE.t)}))).

Module INDEX.
  Record signature {t : Set} {ipath : Set -> Set} := {
    t := t;
    path_length : Z;
    to_path : t -> list string -> list string;
    of_path : list string -> option t;
    ipath := ipath;
    args : forall {a : Set}, Storage_description.args a t (ipath a);
  }.
  Arguments signature : clear implicits.
End INDEX.

Parameter Pair :
  forall (I1 : {'[t, ipath] : _ & INDEX.signature t ipath}),
    (forall (I2 : {'[t, ipath] : _ & INDEX.signature t ipath}),
      {ipath : _ & INDEX.signature ((|I1|).(INDEX.t) * (|I2|).(INDEX.t)) ipath}).

Parameter Make_data_set_storage :
  forall (C : {t : _ & Raw_context.T.signature t}),
    (forall (I : {'[t, ipath] : _ & INDEX.signature t ipath}),
      {_ : unit &
        Data_set_storage.signature (|C|).(Raw_context.T.t) (|I|).(INDEX.t)}).

Parameter Make_indexed_data_storage :
  forall (C : {t : _ & Raw_context.T.signature t}),
    (forall (I : {'[t, ipath] : _ & INDEX.signature t ipath}),
      (forall (V : {t : _ & VALUE.signature t}),
        {_ : unit &
          Indexed_data_storage.signature (|C|).(Raw_context.T.t) (|I|).(INDEX.t)
            (|V|).(Storage_sigs.VALUE.t)})).

Parameter Make_indexed_carbonated_data_storage :
  forall (C : {t : _ & Raw_context.T.signature t}),
    (forall (I : {'[t, ipath] : _ & INDEX.signature t ipath}),
      (forall (V : {t : _ & VALUE.signature t}),
        {_ : unit &
          Non_iterable_indexed_carbonated_data_storage.signature
            (|C|).(Raw_context.T.t) (|I|).(INDEX.t) (|V|).(Storage_sigs.VALUE.t)})).

Parameter Make_indexed_data_snapshotable_storage :
  forall (C : {t : _ & Raw_context.T.signature t}),
    (forall (Snapshot : {'[t, ipath] : _ & INDEX.signature t ipath}),
      (forall (I : {'[t, ipath] : _ & INDEX.signature t ipath}),
        (forall (V : {t : _ & VALUE.signature t}),
          {_ : unit &
            Indexed_data_snapshotable_storage.signature (|Snapshot|).(INDEX.t)
              (|I|).(INDEX.t) (|C|).(Raw_context.T.t)
              (|V|).(Storage_sigs.VALUE.t)}))).

Parameter Make_indexed_subcontext :
  forall (C : {t : _ & Raw_context.T.signature t}),
    (forall (I : {'[t, ipath] : _ & INDEX.signature t ipath}),
      {_ : unit &
        Indexed_raw_context.signature (|C|).(Raw_context.T.t) (|I|).(INDEX.t)
          ((|I|).(INDEX.ipath) a)}).

Parameter Wrap_indexed_data_storage :
  forall (C :
    {'[t, key, value] : _ & Indexed_data_storage.signature t key value}),
    (forall (K : anonymous_signature),
      {_ : unit &
        Indexed_data_storage.signature
          (|C|).(Storage_sigs.Indexed_data_storage.t) K.t
          (|C|).(Storage_sigs.Indexed_data_storage.value)}).

Storage_sigs

  • OCaml size: 412 lines
  • Coq size: 233 lines (-44% compared to OCaml)
storage_sigs.ml success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** {1 Entity Accessor Signatures} *)

(** The generic signature of a single data accessor (a single value
    bound to a specific key in the hierarchical (key x value)
    database). *)
module type Single_data_storage = sig
  type t

  type context = t

  (** The type of the value *)
  type value

  (** Tells if the data is already defined *)
  val mem : context -> bool Lwt.t

  (** Retrieve the value from the storage bucket ; returns a
      {!Storage_error} if the key is not set or if the deserialisation
      fails *)
  val get : context -> value tzresult Lwt.t

  (** Retrieves the value from the storage bucket ; returns [None] if
      the data is not initialized, or {!Storage_helpers.Storage_error}
      if the deserialisation fails *)
  val get_option : context -> value option tzresult Lwt.t

  (** Allocates the storage bucket and initializes it ; returns a
      {!Storage_error Existing_key} if the bucket exists *)
  val init : context -> value -> Raw_context.t tzresult Lwt.t

  (** Updates the content of the bucket ; returns a {!Storage_Error
      Missing_key} if the value does not exists *)
  val set : context -> value -> Raw_context.t tzresult Lwt.t

  (** Allocates the data and initializes it with a value ; just
      updates it if the bucket exists *)
  val init_set : context -> value -> Raw_context.t Lwt.t

  (** When the value is [Some v], allocates the data and initializes
      it with [v] ; just updates it if the bucket exists. When the
      valus is [None], delete the storage bucket when the value ; does
      nothing if the bucket does not exists. *)
  val set_option : context -> value option -> Raw_context.t Lwt.t

  (** Delete the storage bucket ; returns a {!Storage_error
      Missing_key} if the bucket does not exists *)
  val delete : context -> Raw_context.t tzresult Lwt.t

  (** Removes the storage bucket and its contents ; does nothing if
      the bucket does not exists *)
  val remove : context -> Raw_context.t Lwt.t
end

(** Variant of {!Single_data_storage} with gas accounting. *)
module type Single_carbonated_data_storage = sig
  type t

  type context = t

  (** The type of the value *)
  type value

  (** Tells if the data is already defined.
      Consumes [Gas_repr.read_bytes_cost Z.zero]. *)
  val mem : context -> (Raw_context.t * bool) tzresult Lwt.t

  (** Retrieve the value from the storage bucket ; returns a
      {!Storage_error} if the key is not set or if the deserialisation
      fails.
      Consumes [Gas_repr.read_bytes_cost <size of the value>]. *)
  val get : context -> (Raw_context.t * value) tzresult Lwt.t

  (** Retrieves the value from the storage bucket ; returns [None] if
      the data is not initialized, or {!Storage_helpers.Storage_error}
      if the deserialisation fails.
      Consumes [Gas_repr.read_bytes_cost <size of the value>] if present
      or [Gas_repr.read_bytes_cost Z.zero]. *)
  val get_option : context -> (Raw_context.t * value option) tzresult Lwt.t

  (** Allocates the storage bucket and initializes it ; returns a
      {!Storage_error Missing_key} if the bucket exists.
      Consumes [Gas_repr.write_bytes_cost <size of the value>].
      Returns the size. *)
  val init : context -> value -> (Raw_context.t * int) tzresult Lwt.t

  (** Updates the content of the bucket ; returns a {!Storage_Error
      Existing_key} if the value does not exists.
      Consumes [Gas_repr.write_bytes_cost <size of the new value>].
      Returns the difference from the old to the new size. *)
  val set : context -> value -> (Raw_context.t * int) tzresult Lwt.t

  (** Allocates the data and initializes it with a value ; just
      updates it if the bucket exists.
      Consumes [Gas_repr.write_bytes_cost <size of the new value>].
      Returns the difference from the old (maybe 0) to the new size, and a boolean
      indicating if a value was already associated to this key. *)
  val init_set :
    context -> value -> (Raw_context.t * int * bool) tzresult Lwt.t

  (** When the value is [Some v], allocates the data and initializes
      it with [v] ; just updates it if the bucket exists. When the
      valus is [None], delete the storage bucket when the value ; does
      nothing if the bucket does not exists.
      Consumes the same gas cost as either {!remove} or {!init_set}.
      Returns the difference from the old (maybe 0) to the new size, and a boolean
      indicating if a value was already associated to this key. *)
  val set_option :
    context -> value option -> (Raw_context.t * int * bool) tzresult Lwt.t

  (** Delete the storage bucket ; returns a {!Storage_error
      Missing_key} if the bucket does not exists.
      Consumes [Gas_repr.write_bytes_cost Z.zero].
      Returns the freed size. *)
  val delete : context -> (Raw_context.t * int) tzresult Lwt.t

  (** Removes the storage bucket and its contents ; does nothing if
      the bucket does not exists.
      Consumes [Gas_repr.write_bytes_cost Z.zero].
      Returns the freed size, and a boolean
      indicating if a value was already associated to this key. *)
  val remove : context -> (Raw_context.t * int * bool) tzresult Lwt.t
end

(** Restricted version of {!Indexed_data_storage} w/o iterators. *)
module type Non_iterable_indexed_data_storage = sig
  type t

  type context = t

  (** An abstract type for keys *)
  type key

  (** The type of values *)
  type value

  (** Tells if a given key is already bound to a storage bucket *)
  val mem : context -> key -> bool Lwt.t

  (** Retrieve a value from the storage bucket at a given key ;
      returns {!Storage_error Missing_key} if the key is not set ;
      returns {!Storage_error Corrupted_data} if the deserialisation
      fails. *)
  val get : context -> key -> value tzresult Lwt.t

  (** Retrieve a value from the storage bucket at a given key ;
      returns [None] if the value is not set ; returns {!Storage_error
      Corrupted_data} if the deserialisation fails. *)
  val get_option : context -> key -> value option tzresult Lwt.t

  (** Updates the content of a bucket ; returns A {!Storage_Error
      Missing_key} if the value does not exists. *)
  val set : context -> key -> value -> Raw_context.t tzresult Lwt.t

  (** Allocates a storage bucket at the given key and initializes it ;
      returns a {!Storage_error Existing_key} if the bucket exists. *)
  val init : context -> key -> value -> Raw_context.t tzresult Lwt.t

  (** Allocates a storage bucket at the given key and initializes it
      with a value ; just updates it if the bucket exists. *)
  val init_set : context -> key -> value -> Raw_context.t Lwt.t

  (** When the value is [Some v], allocates the data and initializes
      it with [v] ; just updates it if the bucket exists. When the
      valus is [None], delete the storage bucket when the value ; does
      nothing if the bucket does not exists. *)
  val set_option : context -> key -> value option -> Raw_context.t Lwt.t

  (** Delete a storage bucket and its contents ; returns a
      {!Storage_error Missing_key} if the bucket does not exists. *)
  val delete : context -> key -> Raw_context.t tzresult Lwt.t

  (** Removes a storage bucket and its contents ; does nothing if the
      bucket does not exists. *)
  val remove : context -> key -> Raw_context.t Lwt.t
end

(** Variant of {!Non_iterable_indexed_data_storage} with gas accounting. *)
module type Non_iterable_indexed_carbonated_data_storage = sig
  type t

  type context = t

  (** An abstract type for keys *)
  type key

  (** The type of values *)
  type value

  (** Tells if a given key is already bound to a storage bucket.
      Consumes [Gas_repr.read_bytes_cost Z.zero]. *)
  val mem : context -> key -> (Raw_context.t * bool) tzresult Lwt.t

  (** Retrieve a value from the storage bucket at a given key ;
      returns {!Storage_error Missing_key} if the key is not set ;
      returns {!Storage_error Corrupted_data} if the deserialisation
      fails.
      Consumes [Gas_repr.read_bytes_cost <size of the value>]. *)
  val get : context -> key -> (Raw_context.t * value) tzresult Lwt.t

  (** Retrieve a value from the storage bucket at a given key ;
      returns [None] if the value is not set ; returns {!Storage_error
      Corrupted_data} if the deserialisation fails.
      Consumes [Gas_repr.read_bytes_cost <size of the value>] if present
      or [Gas_repr.read_bytes_cost Z.zero]. *)
  val get_option :
    context -> key -> (Raw_context.t * value option) tzresult Lwt.t

  (** Updates the content of a bucket ; returns A {!Storage_Error
      Missing_key} if the value does not exists.
      Consumes serialization cost.
      Consumes [Gas_repr.write_bytes_cost <size of the new value>].
      Returns the difference from the old to the new size. *)
  val set : context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t

  (** Allocates a storage bucket at the given key and initializes it ;
      returns a {!Storage_error Existing_key} if the bucket exists.
      Consumes serialization cost.
      Consumes [Gas_repr.write_bytes_cost <size of the value>].
      Returns the size. *)
  val init : context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t

  (** Allocates a storage bucket at the given key and initializes it
      with a value ; just updates it if the bucket exists.
      Consumes serialization cost.
      Consumes [Gas_repr.write_bytes_cost <size of the new value>].
      Returns the difference from the old (maybe 0) to the new size, and a boolean
      indicating if a value was already associated to this key. *)
  val init_set :
    context -> key -> value -> (Raw_context.t * int * bool) tzresult Lwt.t

  (** When the value is [Some v], allocates the data and initializes
      it with [v] ; just updates it if the bucket exists. When the
      valus is [None], delete the storage bucket when the value ; does
      nothing if the bucket does not exists.
      Consumes serialization cost.
      Consumes the same gas cost as either {!remove} or {!init_set}.
      Returns the difference from the old (maybe 0) to the new size, and a boolean
      indicating if a value was already associated to this key. *)
  val set_option :
    context ->
    key ->
    value option ->
    (Raw_context.t * int * bool) tzresult Lwt.t

  (** Delete a storage bucket and its contents ; returns a
      {!Storage_error Missing_key} if the bucket does not exists.
      Consumes [Gas_repr.write_bytes_cost Z.zero].
      Returns the freed size. *)
  val delete : context -> key -> (Raw_context.t * int) tzresult Lwt.t

  (** Removes a storage bucket and its contents ; does nothing if the
      bucket does not exists.
      Consumes [Gas_repr.write_bytes_cost Z.zero].
      Returns the freed size, and a boolean
      indicating if a value was already associated to this key. *)
  val remove : context -> key -> (Raw_context.t * int * bool) tzresult Lwt.t
end

(** The generic signature of indexed data accessors (a set of values
    of the same type indexed by keys of the same form in the
    hierarchical (key x value) database). *)
module type Indexed_data_storage = sig
  include Non_iterable_indexed_data_storage

  (** Empties all the keys and associated data. *)
  val clear : context -> Raw_context.t Lwt.t

  (** Lists all the keys. *)
  val keys : context -> key list Lwt.t

  (** Lists all the keys and associated data. *)
  val bindings : context -> (key * value) list Lwt.t

  (** Iterates over all the keys and associated data. *)
  val fold :
    context -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  (** Iterate over all the keys. *)
  val fold_keys : context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
end

module type Indexed_data_snapshotable_storage = sig
  type snapshot

  type key

  include Indexed_data_storage with type key := key

  module Snapshot :
    Indexed_data_storage
      with type key = snapshot * key
       and type value = value
       and type t = t

  val snapshot_exists : context -> snapshot -> bool Lwt.t

  val snapshot : context -> snapshot -> Raw_context.t tzresult Lwt.t

  val delete_snapshot : context -> snapshot -> Raw_context.t Lwt.t
end

(** The generic signature of a data set accessor (a set of values
    bound to a specific key prefix in the hierarchical (key x value)
    database). *)
module type Data_set_storage = sig
  type t

  type context = t

  (** The type of elements. *)
  type elt

  (** Tells if a elt is a member of the set *)
  val mem : context -> elt -> bool Lwt.t

  (** Adds a elt is a member of the set *)
  val add : context -> elt -> Raw_context.t Lwt.t

  (** Removes a elt of the set ; does nothing if not a member *)
  val del : context -> elt -> Raw_context.t Lwt.t

  (** Adds/Removes a elt of the set *)
  val set : context -> elt -> bool -> Raw_context.t Lwt.t

  (** Returns the elements of the set, deserialized in a list in no
      particular order. *)
  val elements : context -> elt list Lwt.t

  (** Iterates over the elements of the set. *)
  val fold : context -> init:'a -> f:(elt -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  (** Removes all elements in the set *)
  val clear : context -> Raw_context.t Lwt.t
end

module type NAME = sig
  val name : Raw_context.key
end

module type VALUE = sig
  type t

  val encoding : t Data_encoding.t
end

module type REGISTER = sig
  val ghost : bool
end

module type Indexed_raw_context = sig
  type t

  type context = t

  type key

  type 'a ipath

  val clear : context -> Raw_context.t Lwt.t

  val fold_keys : context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  val keys : context -> key list Lwt.t

  val resolve : context -> string list -> key list Lwt.t

  val remove_rec : context -> key -> context Lwt.t

  val copy : context -> from:key -> to_:key -> context tzresult Lwt.t

  module Make_set (R : REGISTER) (N : NAME) :
    Data_set_storage with type t = t and type elt = key

  module Make_map (N : NAME) (V : VALUE) :
    Indexed_data_storage
      with type t = t
       and type key = key
       and type value = V.t

  module Make_carbonated_map (N : NAME) (V : VALUE) :
    Non_iterable_indexed_carbonated_data_storage
      with type t = t
       and type key = key
       and type value = V.t

  module Raw_context : Raw_context.T with type t = t ipath
end
Storage_sigs.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Raw_context.

Module Single_data_storage.
  Record signature {t value : Set} := {
    t := t;
    context := t;
    value := value;
    mem : context -> Lwt.t bool;
    get : context -> Lwt.t (Error_monad.tzresult value);
    get_option : context -> Lwt.t (Error_monad.tzresult (option value));
    init : context -> value -> Lwt.t (Error_monad.tzresult Raw_context.t);
    set : context -> value -> Lwt.t (Error_monad.tzresult Raw_context.t);
    init_set : context -> value -> Lwt.t Raw_context.t;
    set_option : context -> option value -> Lwt.t Raw_context.t;
    delete : context -> Lwt.t (Error_monad.tzresult Raw_context.t);
    remove : context -> Lwt.t Raw_context.t;
  }.
  Arguments signature : clear implicits.
End Single_data_storage.

Module Single_carbonated_data_storage.
  Record signature {t value : Set} := {
    t := t;
    context := t;
    value := value;
    mem : context -> Lwt.t (Error_monad.tzresult (Raw_context.t * bool));
    get : context -> Lwt.t (Error_monad.tzresult (Raw_context.t * value));
    get_option :
      context -> Lwt.t (Error_monad.tzresult (Raw_context.t * option value));
    init : context -> value -> Lwt.t (Error_monad.tzresult (Raw_context.t * Z));
    set : context -> value -> Lwt.t (Error_monad.tzresult (Raw_context.t * Z));
    init_set :
      context -> value ->
      Lwt.t (Error_monad.tzresult (Raw_context.t * Z * bool));
    set_option :
      context -> option value ->
      Lwt.t (Error_monad.tzresult (Raw_context.t * Z * bool));
    delete : context -> Lwt.t (Error_monad.tzresult (Raw_context.t * Z));
    remove : context -> Lwt.t (Error_monad.tzresult (Raw_context.t * Z * bool));
  }.
  Arguments signature : clear implicits.
End Single_carbonated_data_storage.

Module Non_iterable_indexed_data_storage.
  Record signature {t key value : Set} := {
    t := t;
    context := t;
    key := key;
    value := value;
    mem : context -> key -> Lwt.t bool;
    get : context -> key -> Lwt.t (Error_monad.tzresult value);
    get_option : context -> key -> Lwt.t (Error_monad.tzresult (option value));
    set : context -> key -> value -> Lwt.t (Error_monad.tzresult Raw_context.t);
    init :
      context -> key -> value -> Lwt.t (Error_monad.tzresult Raw_context.t);
    init_set : context -> key -> value -> Lwt.t Raw_context.t;
    set_option : context -> key -> option value -> Lwt.t Raw_context.t;
    delete : context -> key -> Lwt.t (Error_monad.tzresult Raw_context.t);
    remove : context -> key -> Lwt.t Raw_context.t;
  }.
  Arguments signature : clear implicits.
End Non_iterable_indexed_data_storage.

Module Non_iterable_indexed_carbonated_data_storage.
  Record signature {t key value : Set} := {
    t := t;
    context := t;
    key := key;
    value := value;
    mem : context -> key -> Lwt.t (Error_monad.tzresult (Raw_context.t * bool));
    get :
      context -> key -> Lwt.t (Error_monad.tzresult (Raw_context.t * value));
    get_option :
      context -> key ->
      Lwt.t (Error_monad.tzresult (Raw_context.t * option value));
    set :
      context -> key -> value ->
      Lwt.t (Error_monad.tzresult (Raw_context.t * Z));
    init :
      context -> key -> value ->
      Lwt.t (Error_monad.tzresult (Raw_context.t * Z));
    init_set :
      context -> key -> value ->
      Lwt.t (Error_monad.tzresult (Raw_context.t * Z * bool));
    set_option :
      context -> key -> option value ->
      Lwt.t (Error_monad.tzresult (Raw_context.t * Z * bool));
    delete : context -> key -> Lwt.t (Error_monad.tzresult (Raw_context.t * Z));
    remove :
      context -> key -> Lwt.t (Error_monad.tzresult (Raw_context.t * Z * bool));
  }.
  Arguments signature : clear implicits.
End Non_iterable_indexed_carbonated_data_storage.

Module Indexed_data_storage.
  Record signature {t key value : Set} := {
    t := t;
    context := t;
    key := key;
    value := value;
    mem : context -> key -> Lwt.t bool;
    get : context -> key -> Lwt.t (Error_monad.tzresult value);
    get_option : context -> key -> Lwt.t (Error_monad.tzresult (option value));
    set : context -> key -> value -> Lwt.t (Error_monad.tzresult Raw_context.t);
    init :
      context -> key -> value -> Lwt.t (Error_monad.tzresult Raw_context.t);
    init_set : context -> key -> value -> Lwt.t Raw_context.t;
    set_option : context -> key -> option value -> Lwt.t Raw_context.t;
    delete : context -> key -> Lwt.t (Error_monad.tzresult Raw_context.t);
    remove : context -> key -> Lwt.t Raw_context.t;
    clear : context -> Lwt.t Raw_context.t;
    keys : context -> Lwt.t (list key);
    bindings : context -> Lwt.t (list (key * value));
    fold : forall {a : Set},
      context -> a -> (key -> value -> a -> Lwt.t a) -> Lwt.t a;
    fold_keys : forall {a : Set},
      context -> a -> (key -> a -> Lwt.t a) -> Lwt.t a;
  }.
  Arguments signature : clear implicits.
End Indexed_data_storage.

Module Indexed_data_snapshotable_storage.
  Record signature {snapshot key t value : Set} := {
    snapshot := snapshot;
    key := key;
    t := t;
    context := t;
    value := value;
    mem : context -> key -> Lwt.t bool;
    get : context -> key -> Lwt.t (Error_monad.tzresult value);
    get_option : context -> key -> Lwt.t (Error_monad.tzresult (option value));
    set : context -> key -> value -> Lwt.t (Error_monad.tzresult Raw_context.t);
    init :
      context -> key -> value -> Lwt.t (Error_monad.tzresult Raw_context.t);
    init_set : context -> key -> value -> Lwt.t Raw_context.t;
    set_option : context -> key -> option value -> Lwt.t Raw_context.t;
    delete : context -> key -> Lwt.t (Error_monad.tzresult Raw_context.t);
    remove : context -> key -> Lwt.t Raw_context.t;
    clear : context -> Lwt.t Raw_context.t;
    keys : context -> Lwt.t (list key);
    bindings : context -> Lwt.t (list (key * value));
    fold : forall {a : Set},
      context -> a -> (key -> value -> a -> Lwt.t a) -> Lwt.t a;
    fold_keys : forall {a : Set},
      context -> a -> (key -> a -> Lwt.t a) -> Lwt.t a;
    Snapshot : Indexed_data_storage.signature t (snapshot * key) value;
    snapshot_exists : context -> snapshot -> Lwt.t bool;
    __snapshot_value :
      context -> snapshot -> Lwt.t (Error_monad.tzresult Raw_context.t);
    delete_snapshot : context -> snapshot -> Lwt.t Raw_context.t;
  }.
  Arguments signature : clear implicits.
End Indexed_data_snapshotable_storage.

Module Data_set_storage.
  Record signature {t elt : Set} := {
    t := t;
    context := t;
    elt := elt;
    mem : context -> elt -> Lwt.t bool;
    add : context -> elt -> Lwt.t Raw_context.t;
    del : context -> elt -> Lwt.t Raw_context.t;
    set : context -> elt -> bool -> Lwt.t Raw_context.t;
    elements : context -> Lwt.t (list elt);
    fold : forall {a : Set}, context -> a -> (elt -> a -> Lwt.t a) -> Lwt.t a;
    clear : context -> Lwt.t Raw_context.t;
  }.
  Arguments signature : clear implicits.
End Data_set_storage.

Module NAME.
  Record signature := {
    name : Raw_context.key;
  }.
End NAME.

Module VALUE.
  Record signature {t : Set} := {
    t := t;
    encoding : Data_encoding.t t;
  }.
  Arguments signature : clear implicits.
End VALUE.

Module REGISTER.
  Record signature := {
    ghost : bool;
  }.
End REGISTER.

Module Indexed_raw_context.
  Record signature {t key : Set} {ipath : Set -> Set} := {
    t := t;
    context := t;
    key := key;
    ipath := ipath;
    clear : context -> Lwt.t Raw_context.t;
    fold_keys : forall {a : Set},
      context -> a -> (key -> a -> Lwt.t a) -> Lwt.t a;
    keys : context -> Lwt.t (list key);
    resolve : context -> list string -> Lwt.t (list key);
    remove_rec : context -> key -> Lwt.t context;
    copy : context -> key -> key -> Lwt.t (Error_monad.tzresult context);
    Make_set :
      forall (R : {_ : unit & REGISTER.signature}),
        (forall (N : {_ : unit & NAME.signature}),
          {_ : unit & Data_set_storage.signature t key});
    Make_map :
      forall (N : {_ : unit & NAME.signature}),
        (forall (V : {t : _ & VALUE.signature t}),
          {_ : unit & Indexed_data_storage.signature t key V.(VALUE.t)});
    Make_carbonated_map :
      forall (N : {_ : unit & NAME.signature}),
        (forall (V : {t : _ & VALUE.signature t}),
          {_ : unit &
            Non_iterable_indexed_carbonated_data_storage.signature t key
              V.(VALUE.t)});
    Raw_context : Raw_context.T.signature (ipath t);
  }.
  Arguments signature : clear implicits.
End Indexed_raw_context.

Tez_repr

  • OCaml size: 36 lines
  • Coq size: 92 lines (+155% compared to OCaml)
tez_repr.ml success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module QtyModule = Qty_repr.Make (struct
  let id = "tez"
end)

include QtyModule

type t = qty

type tez = qty

let encoding = Data_encoding.def "mutez" @@ qty_encoding
Tez_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Qty_repr.

Definition QtyModule :=
  Qty_repr.Make
    (let id := "tez" in
    existT (fun _ => _) tt
      {|
        Qty_repr.QTY.id := id
      |}).

Definition qty := (|QtyModule|).(Qty_repr.S.qty).

Definition id := (|QtyModule|).(Qty_repr.S.id).

Definition zero := (|QtyModule|).(Qty_repr.S.zero).

Definition one_mutez := (|QtyModule|).(Qty_repr.S.one_mutez).

Definition one_cent := (|QtyModule|).(Qty_repr.S.one_cent).

Definition fifty_cents := (|QtyModule|).(Qty_repr.S.fifty_cents).

Definition one := (|QtyModule|).(Qty_repr.S.one).

Definition op_minusquestion := (|QtyModule|).(Qty_repr.S.op_minusquestion).

Definition op_plusquestion := (|QtyModule|).(Qty_repr.S.op_plusquestion).

Definition op_starquestion := (|QtyModule|).(Qty_repr.S.op_starquestion).

Definition op_divquestion := (|QtyModule|).(Qty_repr.S.op_divquestion).

Definition to_mutez := (|QtyModule|).(Qty_repr.S.to_mutez).

Definition of_mutez := (|QtyModule|).(Qty_repr.S.of_mutez).

Definition of_mutez_exn := (|QtyModule|).(Qty_repr.S.of_mutez_exn).

Definition add_exn := (|QtyModule|).(Qty_repr.S.add_exn).

Definition mul_exn := (|QtyModule|).(Qty_repr.S.mul_exn).

Definition qty_encoding := (|QtyModule|).(Qty_repr.S.qty_encoding).

Definition to_int64 := (|QtyModule|).(Qty_repr.S.to_int64).

Definition op_eq := (|QtyModule|).(Qty_repr.S.op_eq).

Definition op_ltgt := (|QtyModule|).(Qty_repr.S.op_ltgt).

Definition op_lt := (|QtyModule|).(Qty_repr.S.op_lt).

Definition op_lteq := (|QtyModule|).(Qty_repr.S.op_lteq).

Definition op_gteq := (|QtyModule|).(Qty_repr.S.op_gteq).

Definition op_gt := (|QtyModule|).(Qty_repr.S.op_gt).

Definition compare := (|QtyModule|).(Qty_repr.S.compare).

Definition equal := (|QtyModule|).(Qty_repr.S.equal).

Definition max := (|QtyModule|).(Qty_repr.S.max).

Definition min := (|QtyModule|).(Qty_repr.S.min).

Definition pp := (|QtyModule|).(Qty_repr.S.pp).

Definition of_string := (|QtyModule|).(Qty_repr.S.of_string).

Definition to_string := (|QtyModule|).(Qty_repr.S.to_string).

Definition t := qty.

Definition tez := qty.

Definition encoding : Data_encoding.encoding qty :=
  Pervasives.op_atat
    (let arg := Data_encoding.def "mutez" in
    fun eta => arg None None eta) qty_encoding.

Tez_repr_mli

  • OCaml size: 32 lines
  • Coq size: 81 lines (+153% compared to OCaml)
tez_repr.mli 5 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t

type tez = t

include Qty_repr.S with type qty := t

val encoding : t Data_encoding.t
Tez_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Qty_repr.

Parameter t : Set.

Definition tez := t.

Parameter Included_S : {_ : unit & Qty_repr.S.signature t}.

Definition id := (|Included_S|).(Qty_repr.S.id).

Definition zero := (|Included_S|).(Qty_repr.S.zero).

Definition one_mutez := (|Included_S|).(Qty_repr.S.one_mutez).

Definition one_cent := (|Included_S|).(Qty_repr.S.one_cent).

Definition fifty_cents := (|Included_S|).(Qty_repr.S.fifty_cents).

Definition one := (|Included_S|).(Qty_repr.S.one).

Definition op_minusquestion := (|Included_S|).(Qty_repr.S.op_minusquestion).

Definition op_plusquestion := (|Included_S|).(Qty_repr.S.op_plusquestion).

Definition op_starquestion := (|Included_S|).(Qty_repr.S.op_starquestion).

Definition op_divquestion := (|Included_S|).(Qty_repr.S.op_divquestion).

Definition to_mutez := (|Included_S|).(Qty_repr.S.to_mutez).

Definition of_mutez := (|Included_S|).(Qty_repr.S.of_mutez).

Definition of_mutez_exn := (|Included_S|).(Qty_repr.S.of_mutez_exn).

Definition add_exn := (|Included_S|).(Qty_repr.S.add_exn).

Definition mul_exn := (|Included_S|).(Qty_repr.S.mul_exn).

Definition qty_encoding := (|Included_S|).(Qty_repr.S.qty_encoding).

Definition to_int64 := (|Included_S|).(Qty_repr.S.to_int64).

Definition op_eq := (|Included_S|).(Qty_repr.S.op_eq).

Definition op_ltgt := (|Included_S|).(Qty_repr.S.op_ltgt).

Definition op_lt := (|Included_S|).(Qty_repr.S.op_lt).

Definition op_lteq := (|Included_S|).(Qty_repr.S.op_lteq).

Definition op_gteq := (|Included_S|).(Qty_repr.S.op_gteq).

Definition op_gt := (|Included_S|).(Qty_repr.S.op_gt).

Definition compare := (|Included_S|).(Qty_repr.S.compare).

Definition equal := (|Included_S|).(Qty_repr.S.equal).

Definition max := (|Included_S|).(Qty_repr.S.max).

Definition min := (|Included_S|).(Qty_repr.S.min).

Definition pp := (|Included_S|).(Qty_repr.S.pp).

Definition of_string := (|Included_S|).(Qty_repr.S.of_string).

Definition to_string := (|Included_S|).(Qty_repr.S.to_string).

Parameter encoding : Data_encoding.t t.

Time_repr

  • OCaml size: 66 lines
  • Coq size: 46 lines (-31% compared to OCaml)
time_repr.ml 6 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Time

type time = t

type error += Timestamp_add (* `Permanent *)

type error += Timestamp_sub (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"timestamp_add"
    ~title:"Timestamp add"
    ~description:"Overflow when adding timestamps."
    ~pp:(fun ppf () -> Format.fprintf ppf "Overflow when adding timestamps.")
    Data_encoding.empty
    (function Timestamp_add -> Some () | _ -> None)
    (fun () -> Timestamp_add) ;
  register_error_kind
    `Permanent
    ~id:"timestamp_sub"
    ~title:"Timestamp sub"
    ~description:"Substracting timestamps resulted in negative period."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Substracting timestamps resulted in negative period.")
    Data_encoding.empty
    (function Timestamp_sub -> Some () | _ -> None)
    (fun () -> Timestamp_sub)

let of_seconds s = try Some (of_seconds (Int64.of_string s)) with _ -> None

let to_seconds = to_seconds

let to_seconds_string s = Int64.to_string (to_seconds s)

let pp = pp_hum

let ( +? ) x y =
  try ok (add x (Period_repr.to_seconds y)) with _exn -> error Timestamp_add

let ( -? ) x y = record_trace Timestamp_sub (Period_repr.of_seconds (diff x y))
Time_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Period_repr.

Include Time.

Definition time := t.

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Structure item `typext` not handled. *)
(* type_extension *)

(* ❌ Top-level evaluations are not handled *)
(* top_level_evaluation *)

Definition of_seconds (s : string) : option t :=
  (* ❌ Try-with are not handled *)
  try (Some (of_seconds (Int64.of_string s))).

Definition to_seconds : t -> int64 := to_seconds.

Definition to_seconds_string (s : t) : string := Int64.to_string (to_seconds s).

Definition pp : Format.formatter -> t -> unit := pp_hum.

Definition op_plusquestion (x : t) (y : Period_repr.period)
  : Error_monad.tzresult t :=
  (* ❌ Try-with are not handled *)
  try (Error_monad.ok (add x (Period_repr.to_seconds y))).

Definition op_minusquestion (x : t) (y : t)
  : Error_monad.tzresult Period_repr.period :=
  Error_monad.record_trace extensible_type_value
    (Period_repr.of_seconds (diff x y)).

Time_repr_mli

  • OCaml size: 38 lines
  • Coq size: 25 lines (-35% compared to OCaml)
time_repr.mli 2 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include module type of Time

type time = t

val pp : Format.formatter -> t -> unit

val of_seconds : string -> time option

val to_seconds_string : time -> string

val ( +? ) : time -> Period_repr.t -> time tzresult

val ( -? ) : time -> time -> Period_repr.t tzresult
Time_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Period_repr.

Definition time := t.

Parameter pp : Format.formatter -> t -> unit.

Parameter of_seconds : string -> option time.

Parameter to_seconds_string : time -> string.

Parameter op_plusquestion : time -> Period_repr.t -> Error_monad.tzresult time.

Parameter op_minusquestion : time -> time -> Error_monad.tzresult Period_repr.t.

Vote_repr

  • OCaml size: 46 lines
  • Coq size: 37 lines (-20% compared to OCaml)
vote_repr.ml success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type proposal = Protocol_hash.t

type ballot = Yay | Nay | Pass

let ballot_encoding =
  let of_int8 = function
    | 0 ->
        Yay
    | 1 ->
        Nay
    | 2 ->
        Pass
    | _ ->
        invalid_arg "ballot_of_int8"
  in
  let to_int8 = function Yay -> 0 | Nay -> 1 | Pass -> 2 in
  let open Data_encoding in
  (* union *)
  splitted
    ~binary:(conv to_int8 of_int8 int8)
    ~json:(string_enum [("yay", Yay); ("nay", Nay); ("pass", Pass)])
Vote_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Definition proposal := (|Protocol_hash|).(S.HASH.t).

Inductive ballot : Set :=
| Yay : ballot
| Nay : ballot
| Pass : ballot.

Definition ballot_encoding : Data_encoding.encoding ballot :=
  let of_int8 (function_parameter : Z) : ballot :=
    match function_parameter with
    | 0 => Yay
    | 1 => Nay
    | 2 => Pass
    | _ => Pervasives.invalid_arg "ballot_of_int8"
    end in
  let to_int8 (function_parameter : ballot) : Z :=
    match function_parameter with
    | Yay => 0
    | Nay => 1
    | Pass => 2
    end in
  Data_encoding.splitted
    (Data_encoding.string_enum [ ("yay", Yay); ("nay", Nay); ("pass", Pass) ])
    (Data_encoding.conv to_int8 of_int8 None Data_encoding.int8).

Vote_repr_mli

  • OCaml size: 33 lines
  • Coq size: 21 lines (-37% compared to OCaml)
vote_repr.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** a protocol change proposal *)
type proposal = Protocol_hash.t

(** votes can be for, against or neutral.
    Neutral serves to count towards a quorum *)
type ballot = Yay | Nay | Pass

val ballot_encoding : ballot Data_encoding.t
Vote_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Definition proposal := (|Protocol_hash|).(S.HASH.t).

Inductive ballot : Set :=
| Yay : ballot
| Nay : ballot
| Pass : ballot.

Parameter ballot_encoding : Data_encoding.t ballot.

Vote_storage

  • OCaml size: 156 lines
  • Coq size: 290 lines (+85% compared to OCaml)
vote_storage.ml success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let recorded_proposal_count_for_delegate ctxt proposer =
  Storage.Vote.Proposals_count.get_option ctxt proposer
  >>=? function None -> return 0 | Some count -> return count

let record_proposal ctxt proposal proposer =
  recorded_proposal_count_for_delegate ctxt proposer
  >>=? fun count ->
  Storage.Vote.Proposals_count.init_set ctxt proposer (count + 1)
  >>= fun ctxt ->
  Storage.Vote.Proposals.add ctxt (proposal, proposer)
  >>= fun ctxt -> return ctxt

let get_proposals ctxt =
  Storage.Vote.Proposals.fold
    ctxt
    ~init:(ok Protocol_hash.Map.empty)
    ~f:(fun (proposal, delegate) acc ->
      (* Assuming the same listings is used at votings *)
      Storage.Vote.Listings.get ctxt delegate
      >>=? fun weight ->
      Lwt.return
        ( acc
        >>? fun acc ->
        let previous =
          match Protocol_hash.Map.find_opt proposal acc with
          | None ->
              0l
          | Some x ->
              x
        in
        ok (Protocol_hash.Map.add proposal (Int32.add weight previous) acc) ))

let clear_proposals ctxt =
  Storage.Vote.Proposals_count.clear ctxt
  >>= fun ctxt -> Storage.Vote.Proposals.clear ctxt

type ballots = {yay : int32; nay : int32; pass : int32}

let ballots_encoding =
  let open Data_encoding in
  conv
    (fun {yay; nay; pass} -> (yay, nay, pass))
    (fun (yay, nay, pass) -> {yay; nay; pass})
  @@ obj3 (req "yay" int32) (req "nay" int32) (req "pass" int32)

let has_recorded_ballot = Storage.Vote.Ballots.mem

let record_ballot = Storage.Vote.Ballots.init

let get_ballots ctxt =
  Storage.Vote.Ballots.fold
    ctxt
    ~f:(fun delegate ballot (ballots : ballots tzresult) ->
      (* Assuming the same listings is used at votings *)
      Storage.Vote.Listings.get ctxt delegate
      >>=? fun weight ->
      let count = Int32.add weight in
      Lwt.return
        ( ballots
        >>? fun ballots ->
        match ballot with
        | Yay ->
            ok {ballots with yay = count ballots.yay}
        | Nay ->
            ok {ballots with nay = count ballots.nay}
        | Pass ->
            ok {ballots with pass = count ballots.pass} ))
    ~init:(ok {yay = 0l; nay = 0l; pass = 0l})

let get_ballot_list = Storage.Vote.Ballots.bindings

let clear_ballots = Storage.Vote.Ballots.clear

let listings_encoding =
  Data_encoding.(
    list
      (obj2 (req "pkh" Signature.Public_key_hash.encoding) (req "rolls" int32)))

let freeze_listings ctxt =
  Roll_storage.fold ctxt (ctxt, 0l) ~f:(fun _roll delegate (ctxt, total) ->
      (* TODO use snapshots *)
      let delegate = Signature.Public_key.hash delegate in
      Storage.Vote.Listings.get_option ctxt delegate
      >>=? (function None -> return 0l | Some count -> return count)
      >>=? fun count ->
      Storage.Vote.Listings.init_set ctxt delegate (Int32.succ count)
      >>= fun ctxt -> return (ctxt, Int32.succ total))
  >>=? fun (ctxt, total) ->
  Storage.Vote.Listings_size.init ctxt total >>=? fun ctxt -> return ctxt

let listing_size = Storage.Vote.Listings_size.get

let in_listings = Storage.Vote.Listings.mem

let get_listings = Storage.Vote.Listings.bindings

let clear_listings ctxt =
  Storage.Vote.Listings.clear ctxt
  >>= fun ctxt ->
  Storage.Vote.Listings_size.remove ctxt >>= fun ctxt -> return ctxt

let get_current_period_kind = Storage.Vote.Current_period_kind.get

let set_current_period_kind = Storage.Vote.Current_period_kind.set

let get_current_quorum ctxt =
  Storage.Vote.Participation_ema.get ctxt
  >>=? fun participation_ema ->
  let quorum_min = Constants_storage.quorum_min ctxt in
  let quorum_max = Constants_storage.quorum_max ctxt in
  let quorum_diff = Int32.sub quorum_max quorum_min in
  return
    Int32.(add quorum_min (div (mul participation_ema quorum_diff) 100_00l))

let get_participation_ema = Storage.Vote.Participation_ema.get

let set_participation_ema = Storage.Vote.Participation_ema.set

let get_current_proposal = Storage.Vote.Current_proposal.get

let init_current_proposal = Storage.Vote.Current_proposal.init

let clear_current_proposal = Storage.Vote.Current_proposal.delete

let init ctxt =
  (* participation EMA is in centile of a percentage *)
  let participation_ema = Constants_storage.quorum_max ctxt in
  Storage.Vote.Participation_ema.init ctxt participation_ema
  >>=? fun ctxt ->
  Storage.Vote.Current_period_kind.init ctxt Proposal
  >>=? fun ctxt -> return ctxt
Vote_storage.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Constants_storage.
Require Tezos.Raw_context.
Require Tezos.Roll_storage.
Require Tezos.Storage.
Require Tezos.Vote_repr.
Require Tezos.Voting_period_repr.

Definition recorded_proposal_count_for_delegate
  (ctxt : Storage.Vote.Proposals_count.context)
  (proposer : Storage.Vote.Proposals_count.key)
  : Lwt.t (Error_monad.tzresult Storage.Vote.Proposals_count.value) :=
  Error_monad.op_gtgteqquestion
    (Storage.Vote.Proposals_count.get_option ctxt proposer)
    (fun function_parameter =>
      match function_parameter with
      | None => Error_monad.__return 0
      | Some count => Error_monad.__return count
      end).

Definition record_proposal
  (ctxt : Storage.Vote.Proposals_count.context)
  (proposal : (|Protocol_hash|).(S.HASH.t))
  (proposer : Storage.Vote.Proposals_count.key)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Error_monad.op_gtgteqquestion
    (recorded_proposal_count_for_delegate ctxt proposer)
    (fun count =>
      Error_monad.op_gtgteq
        (Storage.Vote.Proposals_count.init_set ctxt proposer
          (Pervasives.op_plus count 1))
        (fun ctxt =>
          Error_monad.op_gtgteq
            (Storage.Vote.Proposals.add ctxt (proposal, proposer))
            (fun ctxt => Error_monad.__return ctxt))).

Definition get_proposals (ctxt : Storage.Vote.Proposals.context)
  : Lwt.t
    (Error_monad.tzresult
      ((|Protocol_hash|).(S.HASH.Map).(S.INDEXES_Map.t) int32)) :=
  Storage.Vote.Proposals.fold ctxt
    (Error_monad.ok (|Protocol_hash|).(S.HASH.Map).(S.INDEXES_Map.empty))
    (fun function_parameter =>
      let '(proposal, delegate) := function_parameter in
      fun acc =>
        Error_monad.op_gtgteqquestion (Storage.Vote.Listings.get ctxt delegate)
          (fun weight =>
            Lwt.__return
              (Error_monad.op_gtgtquestion acc
                (fun acc =>
                  let previous :=
                    match
                      (|Protocol_hash|).(S.HASH.Map).(S.INDEXES_Map.find_opt)
                        proposal acc with
                    | None =>
                      (* ❌ Constant of type int32 is converted to int *)
                      0
                    | Some x => x
                    end in
                  Error_monad.ok
                    ((|Protocol_hash|).(S.HASH.Map).(S.INDEXES_Map.add) proposal
                      (Int32.add weight previous) acc))))).

Definition clear_proposals (ctxt : Storage.Vote.Proposals_count.context)
  : Lwt.t Raw_context.t :=
  Error_monad.op_gtgteq (Storage.Vote.Proposals_count.clear ctxt)
    (fun ctxt => Storage.Vote.Proposals.clear ctxt).

Module ballots.
  Record record := Build {
    yay : int32;
    nay : int32;
    pass : int32 }.
  Definition with_yay yay (r : record) :=
    Build yay r.(nay) r.(pass).
  Definition with_nay nay (r : record) :=
    Build r.(yay) nay r.(pass).
  Definition with_pass pass (r : record) :=
    Build r.(yay) r.(nay) pass.
End ballots.
Definition ballots := ballots.record.

Definition ballots_encoding : Data_encoding.encoding ballots :=
  Pervasives.op_atat
    (let arg :=
      Data_encoding.conv
        (fun function_parameter =>
          let '{|
            ballots.yay := yay; ballots.nay := nay; ballots.pass := pass |} :=
            function_parameter in
          (yay, nay, pass))
        (fun function_parameter =>
          let '(yay, nay, pass) := function_parameter in
          {| ballots.yay := yay; ballots.nay := nay; ballots.pass := pass |}) in
    fun eta => arg None eta)
    (Data_encoding.obj3
      (Data_encoding.req None None "yay" Data_encoding.__int32_value)
      (Data_encoding.req None None "nay" Data_encoding.__int32_value)
      (Data_encoding.req None None "pass" Data_encoding.__int32_value)).

Definition has_recorded_ballot
  : Storage.Vote.Ballots.context -> Storage.Vote.Ballots.key -> Lwt.t bool :=
  Storage.Vote.Ballots.mem.

Definition record_ballot
  : Storage.Vote.Ballots.context -> Storage.Vote.Ballots.key ->
  Storage.Vote.Ballots.value -> Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Storage.Vote.Ballots.init.

Definition get_ballots (ctxt : Storage.Vote.Ballots.context)
  : Lwt.t (Error_monad.tzresult ballots) :=
  Storage.Vote.Ballots.fold ctxt
    (Error_monad.ok
      {|
        ballots.yay :=
          (* ❌ Constant of type int32 is converted to int *)
          0;
        ballots.nay :=
          (* ❌ Constant of type int32 is converted to int *)
          0;
        ballots.pass :=
          (* ❌ Constant of type int32 is converted to int *)
          0 |})
    (fun delegate =>
      fun ballot =>
        fun ballots =>
          Error_monad.op_gtgteqquestion
            (Storage.Vote.Listings.get ctxt delegate)
            (fun weight =>
              let count := Int32.add weight in
              Lwt.__return
                (Error_monad.op_gtgtquestion ballots
                  (fun ballots =>
                    match ballot with
                    | Vote_repr.Yay =>
                      Error_monad.ok
                        (ballots.with_yay (count (ballots.yay ballots)) ballots)
                    | Vote_repr.Nay =>
                      Error_monad.ok
                        (ballots.with_nay (count (ballots.nay ballots)) ballots)
                    | Vote_repr.Pass =>
                      Error_monad.ok
                        (ballots.with_pass (count (ballots.pass ballots))
                          ballots)
                    end)))).

Definition get_ballot_list
  : Storage.Vote.Ballots.context ->
  Lwt.t (list (Storage.Vote.Ballots.key * Storage.Vote.Ballots.value)) :=
  Storage.Vote.Ballots.bindings.

Definition clear_ballots
  : Storage.Vote.Ballots.context -> Lwt.t Raw_context.t :=
  Storage.Vote.Ballots.clear.

Definition listings_encoding
  : Data_encoding.encoding
    (list ((|Signature.Public_key_hash|).(S.SPublic_key_hash.t) * int32)) :=
  Data_encoding.__list_value None
    (Data_encoding.obj2
      (Data_encoding.req None None "pkh"
        (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding))
      (Data_encoding.req None None "rolls" Data_encoding.__int32_value)).

Definition freeze_listings (ctxt : Raw_context.t)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Error_monad.op_gtgteqquestion
    (Roll_storage.fold ctxt
      (fun _roll =>
        fun delegate =>
          fun function_parameter =>
            let '(ctxt, total) := function_parameter in
            let delegate :=
              (|Signature.Public_key|).(S.SPublic_key.__hash_value) delegate in
            Error_monad.op_gtgteqquestion
              (Error_monad.op_gtgteqquestion
                (Storage.Vote.Listings.get_option ctxt delegate)
                (fun function_parameter =>
                  match function_parameter with
                  | None =>
                    Error_monad.__return
                      (* ❌ Constant of type int32 is converted to int *)
                      0
                  | Some count => Error_monad.__return count
                  end))
              (fun count =>
                Error_monad.op_gtgteq
                  (Storage.Vote.Listings.init_set ctxt delegate
                    (Int32.succ count))
                  (fun ctxt => Error_monad.__return (ctxt, (Int32.succ total)))))
      (ctxt,
        (* ❌ Constant of type int32 is converted to int *)
        0))
    (fun function_parameter =>
      let '(ctxt, total) := function_parameter in
      Error_monad.op_gtgteqquestion (Storage.Vote.Listings_size.init ctxt total)
        (fun ctxt => Error_monad.__return ctxt)).

Definition listing_size
  : Storage.Vote.Listings_size.context ->
  Lwt.t (Error_monad.tzresult Storage.Vote.Listings_size.value) :=
  Storage.Vote.Listings_size.get.

Definition in_listings
  : Storage.Vote.Listings.context -> Storage.Vote.Listings.key -> Lwt.t bool :=
  Storage.Vote.Listings.mem.

Definition get_listings
  : Storage.Vote.Listings.context ->
  Lwt.t (list (Storage.Vote.Listings.key * Storage.Vote.Listings.value)) :=
  Storage.Vote.Listings.bindings.

Definition clear_listings (ctxt : Storage.Vote.Listings.context)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Error_monad.op_gtgteq (Storage.Vote.Listings.clear ctxt)
    (fun ctxt =>
      Error_monad.op_gtgteq (Storage.Vote.Listings_size.remove ctxt)
        (fun ctxt => Error_monad.__return ctxt)).

Definition get_current_period_kind
  : Storage.Vote.Current_period_kind.context ->
  Lwt.t (Error_monad.tzresult Storage.Vote.Current_period_kind.value) :=
  Storage.Vote.Current_period_kind.get.

Definition set_current_period_kind
  : Storage.Vote.Current_period_kind.context ->
  Storage.Vote.Current_period_kind.value ->
  Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Storage.Vote.Current_period_kind.set.

Definition get_current_quorum (ctxt : Storage.Vote.Participation_ema.context)
  : Lwt.t (Error_monad.tzresult int32) :=
  Error_monad.op_gtgteqquestion (Storage.Vote.Participation_ema.get ctxt)
    (fun participation_ema =>
      let quorum_min := Constants_storage.quorum_min ctxt in
      let quorum_max := Constants_storage.quorum_max ctxt in
      let quorum_diff := Int32.sub quorum_max quorum_min in
      Error_monad.__return
        (Int32.add quorum_min
          (Int32.div (Int32.mul participation_ema quorum_diff)
            (* ❌ Constant of type int32 is converted to int *)
            10000))).

Definition get_participation_ema
  : Storage.Vote.Participation_ema.context ->
  Lwt.t (Error_monad.tzresult Storage.Vote.Participation_ema.value) :=
  Storage.Vote.Participation_ema.get.

Definition set_participation_ema
  : Storage.Vote.Participation_ema.context ->
  Storage.Vote.Participation_ema.value ->
  Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Storage.Vote.Participation_ema.set.

Definition get_current_proposal
  : Storage.Vote.Current_proposal.context ->
  Lwt.t (Error_monad.tzresult Storage.Vote.Current_proposal.value) :=
  Storage.Vote.Current_proposal.get.

Definition init_current_proposal
  : Storage.Vote.Current_proposal.context ->
  Storage.Vote.Current_proposal.value ->
  Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Storage.Vote.Current_proposal.init.

Definition clear_current_proposal
  : Storage.Vote.Current_proposal.context ->
  Lwt.t (Error_monad.tzresult Raw_context.t) :=
  Storage.Vote.Current_proposal.delete.

Definition init (ctxt : Raw_context.context)
  : Lwt.t (Error_monad.tzresult Raw_context.t) :=
  let participation_ema := Constants_storage.quorum_max ctxt in
  Error_monad.op_gtgteqquestion
    (Storage.Vote.Participation_ema.init ctxt participation_ema)
    (fun ctxt =>
      Error_monad.op_gtgteqquestion
        (Storage.Vote.Current_period_kind.init ctxt Voting_period_repr.Proposal)
        (fun ctxt => Error_monad.__return ctxt)).

Vote_storage_mli

  • OCaml size: 106 lines
  • Coq size: 114 lines (+7% compared to OCaml)
vote_storage.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Manages all the voting related storage in Storage.Vote.  *)

(** Records a protocol proposal with the delegate that proposed it. *)
val record_proposal :
  Raw_context.t ->
  Protocol_hash.t ->
  Signature.Public_key_hash.t ->
  Raw_context.t tzresult Lwt.t

val recorded_proposal_count_for_delegate :
  Raw_context.t -> Signature.Public_key_hash.t -> int tzresult Lwt.t

(** Computes for each proposal how many delegates proposed it. *)
val get_proposals : Raw_context.t -> int32 Protocol_hash.Map.t tzresult Lwt.t

val clear_proposals : Raw_context.t -> Raw_context.t Lwt.t

(** Counts of the votes *)
type ballots = {yay : int32; nay : int32; pass : int32}

val ballots_encoding : ballots Data_encoding.t

val has_recorded_ballot :
  Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t

(** Records a vote for a delegate, returns a {!Storage_error Existing_key} if
    the vote was already registered *)
val record_ballot :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Vote_repr.ballot ->
  Raw_context.t tzresult Lwt.t

(** Computes the sum of the current ballots weighted by stake. *)
val get_ballots : Raw_context.t -> ballots tzresult Lwt.t

val get_ballot_list :
  Raw_context.t -> (Signature.Public_key_hash.t * Vote_repr.ballot) list Lwt.t

val clear_ballots : Raw_context.t -> Raw_context.t Lwt.t

val listings_encoding :
  (Signature.Public_key_hash.t * int32) list Data_encoding.t

(** Populates [!Storage.Vote.Listings] using the currently existing rolls and
    sets Listings_size. Delegates without rolls are not included in the listing. *)
val freeze_listings : Raw_context.t -> Raw_context.t tzresult Lwt.t

val clear_listings : Raw_context.t -> Raw_context.t tzresult Lwt.t

(** Returns the sum of all rolls of all delegates. *)
val listing_size : Raw_context.t -> int32 tzresult Lwt.t

(** Verifies the presence of a delegate in the listing. *)
val in_listings : Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t

val get_listings :
  Raw_context.t -> (Signature.Public_key_hash.t * int32) list Lwt.t

val get_current_quorum : Raw_context.t -> int32 tzresult Lwt.t

val get_participation_ema : Raw_context.t -> int32 tzresult Lwt.t

val set_participation_ema :
  Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t

val get_current_period_kind :
  Raw_context.t -> Voting_period_repr.kind tzresult Lwt.t

val set_current_period_kind :
  Raw_context.t -> Voting_period_repr.kind -> Raw_context.t tzresult Lwt.t

val get_current_proposal : Raw_context.t -> Protocol_hash.t tzresult Lwt.t

val init_current_proposal :
  Raw_context.t -> Protocol_hash.t -> Raw_context.t tzresult Lwt.t

val clear_current_proposal : Raw_context.t -> Raw_context.t tzresult Lwt.t

(** Sets the initial quorum to 80% and period kind to proposal. *)
val init : Raw_context.t -> Raw_context.t tzresult Lwt.t
Vote_storage_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Raw_context.
Require Tezos.Vote_repr.
Require Tezos.Voting_period_repr.

Parameter record_proposal :
  Raw_context.t -> (|Protocol_hash|).(S.HASH.t) ->
  (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter recorded_proposal_count_for_delegate :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t (Error_monad.tzresult Z).

Parameter get_proposals :
  Raw_context.t ->
  Lwt.t
    (Error_monad.tzresult
      ((|Protocol_hash|).(S.HASH.Map).(S.INDEXES_Map.t) int32)).

Parameter clear_proposals : Raw_context.t -> Lwt.t Raw_context.t.

Module ballots.
  Record record := Build {
    yay : int32;
    nay : int32;
    pass : int32 }.
  Definition with_yay yay (r : record) :=
    Build yay r.(nay) r.(pass).
  Definition with_nay nay (r : record) :=
    Build r.(yay) nay r.(pass).
  Definition with_pass pass (r : record) :=
    Build r.(yay) r.(nay) pass.
End ballots.
Definition ballots := ballots.record.

Parameter ballots_encoding : Data_encoding.t ballots.

Parameter has_recorded_ballot :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t bool.

Parameter record_ballot :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Vote_repr.ballot -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter get_ballots : Raw_context.t -> Lwt.t (Error_monad.tzresult ballots).

Parameter get_ballot_list :
  Raw_context.t ->
  Lwt.t
    (list
      ((|Signature.Public_key_hash|).(S.SPublic_key_hash.t) * Vote_repr.ballot)).

Parameter clear_ballots : Raw_context.t -> Lwt.t Raw_context.t.

Parameter listings_encoding :
  Data_encoding.t
    (list ((|Signature.Public_key_hash|).(S.SPublic_key_hash.t) * int32)).

Parameter freeze_listings :
  Raw_context.t -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter clear_listings :
  Raw_context.t -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter listing_size : Raw_context.t -> Lwt.t (Error_monad.tzresult int32).

Parameter in_listings :
  Raw_context.t -> (|Signature.Public_key_hash|).(S.SPublic_key_hash.t) ->
  Lwt.t bool.

Parameter get_listings :
  Raw_context.t ->
  Lwt.t (list ((|Signature.Public_key_hash|).(S.SPublic_key_hash.t) * int32)).

Parameter get_current_quorum :
  Raw_context.t -> Lwt.t (Error_monad.tzresult int32).

Parameter get_participation_ema :
  Raw_context.t -> Lwt.t (Error_monad.tzresult int32).

Parameter set_participation_ema :
  Raw_context.t -> int32 -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter get_current_period_kind :
  Raw_context.t -> Lwt.t (Error_monad.tzresult Voting_period_repr.kind).

Parameter set_current_period_kind :
  Raw_context.t -> Voting_period_repr.kind ->
  Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter get_current_proposal :
  Raw_context.t -> Lwt.t (Error_monad.tzresult (|Protocol_hash|).(S.HASH.t)).

Parameter init_current_proposal :
  Raw_context.t -> (|Protocol_hash|).(S.HASH.t) ->
  Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter clear_current_proposal :
  Raw_context.t -> Lwt.t (Error_monad.tzresult Raw_context.t).

Parameter init : Raw_context.t -> Lwt.t (Error_monad.tzresult Raw_context.t).

Voting_period_repr

  • OCaml size: 91 lines
  • Coq size: 128 lines (+40% compared to OCaml)
voting_period_repr.ml 2 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = int32

type voting_period = t

include (Compare.Int32 : Compare.S with type t := t)

let encoding = Data_encoding.int32

let pp ppf level = Format.fprintf ppf "%ld" level

let rpc_arg =
  let construct voting_period = Int32.to_string voting_period in
  let destruct str =
    match Int32.of_string str with
    | exception _ ->
        Error "Cannot parse voting period"
    | voting_period ->
        Ok voting_period
  in
  RPC_arg.make
    ~descr:"A voting period"
    ~name:"voting_period"
    ~construct
    ~destruct
    ()

let root = 0l

let succ = Int32.succ

let to_int32 l = l

let of_int32_exn l =
  if Compare.Int32.(l >= 0l) then l
  else invalid_arg "Voting_period_repr.of_int32"

type kind = Proposal | Testing_vote | Testing | Promotion_vote

let kind_encoding =
  let open Data_encoding in
  union
    ~tag_size:`Uint8
    [ case
        (Tag 0)
        ~title:"Proposal"
        (constant "proposal")
        (function Proposal -> Some () | _ -> None)
        (fun () -> Proposal);
      case
        (Tag 1)
        ~title:"Testing_vote"
        (constant "testing_vote")
        (function Testing_vote -> Some () | _ -> None)
        (fun () -> Testing_vote);
      case
        (Tag 2)
        ~title:"Testing"
        (constant "testing")
        (function Testing -> Some () | _ -> None)
        (fun () -> Testing);
      case
        (Tag 3)
        ~title:"Promotion_vote"
        (constant "promotion_vote")
        (function Promotion_vote -> Some () | _ -> None)
        (fun () -> Promotion_vote) ]
Voting_period_repr.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Definition t := int32.

Definition voting_period := t.

Definition op_eq := (|Compare.Int32|).(Compare.S.op_eq).

Definition op_ltgt := (|Compare.Int32|).(Compare.S.op_ltgt).

Definition op_lt := (|Compare.Int32|).(Compare.S.op_lt).

Definition op_lteq := (|Compare.Int32|).(Compare.S.op_lteq).

Definition op_gteq := (|Compare.Int32|).(Compare.S.op_gteq).

Definition op_gt := (|Compare.Int32|).(Compare.S.op_gt).

Definition compare := (|Compare.Int32|).(Compare.S.compare).

Definition equal := (|Compare.Int32|).(Compare.S.equal).

Definition max := (|Compare.Int32|).(Compare.S.max).

Definition min := (|Compare.Int32|).(Compare.S.min).

Definition encoding : Data_encoding.encoding int32 :=
  Data_encoding.__int32_value.

Definition pp (ppf : Format.formatter) (level : int32) : unit :=
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
        CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.No_precision
        CamlinternalFormatBasics.End_of_format) "%ld") level.

Definition rpc_arg : RPC_arg.arg int32 :=
  let construct (voting_period : int32) : string :=
    Int32.to_string voting_period in
  let destruct (str : string) : Pervasives.result int32 string :=
    let 'voting_period := Int32.of_string str in
    Pervasives.Ok voting_period in
  RPC_arg.make (Some "A voting period") "voting_period" destruct construct tt.

Definition root : int32 :=
  (* ❌ Constant of type int32 is converted to int *)
  0.

Definition succ : int32 -> int32 := Int32.succ.

Definition to_int32 {A : Set} (l : A) : A := l.

Definition of_int32_exn (l : (|Compare.Int32|).(Compare.S.t))
  : (|Compare.Int32|).(Compare.S.t) :=
  if
    (|Compare.Int32|).(Compare.S.op_gteq) l
      (* ❌ Constant of type int32 is converted to int *)
      0 then
    l
  else
    Pervasives.invalid_arg "Voting_period_repr.of_int32".

Inductive kind : Set :=
| Proposal : kind
| Testing_vote : kind
| Testing : kind
| Promotion_vote : kind.

Definition kind_encoding : Data_encoding.encoding kind :=
  Data_encoding.union
    (Some
      (* ❌ Variants not supported *)
      (* ❌ `Uint8 *)
      Data_encoding.Uint8)
    [
      Data_encoding.__case_value "Proposal" None (Data_encoding.Tag 0)
        (Data_encoding.constant "proposal")
        (fun function_parameter =>
          match function_parameter with
          | Proposal => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          let '_ := function_parameter in
          Proposal);
      Data_encoding.__case_value "Testing_vote" None (Data_encoding.Tag 1)
        (Data_encoding.constant "testing_vote")
        (fun function_parameter =>
          match function_parameter with
          | Testing_vote => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          let '_ := function_parameter in
          Testing_vote);
      Data_encoding.__case_value "Testing" None (Data_encoding.Tag 2)
        (Data_encoding.constant "testing")
        (fun function_parameter =>
          match function_parameter with
          | Testing => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          let '_ := function_parameter in
          Testing);
      Data_encoding.__case_value "Promotion_vote" None (Data_encoding.Tag 3)
        (Data_encoding.constant "promotion_vote")
        (fun function_parameter =>
          match function_parameter with
          | Promotion_vote => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          let '_ := function_parameter in
          Promotion_vote)
    ].

Voting_period_repr_mli

  • OCaml size: 55 lines
  • Coq size: 60 lines (+9% compared to OCaml)
voting_period_repr.mli success 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** A voting period can be of 4 kinds and is uniquely identified as a counter
    since the root. *)

type t

type voting_period = t

val encoding : voting_period Data_encoding.t

val rpc_arg : voting_period RPC_arg.arg

val pp : Format.formatter -> voting_period -> unit

include Compare.S with type t := voting_period

val to_int32 : voting_period -> int32

val of_int32_exn : int32 -> voting_period

val root : voting_period

val succ : voting_period -> voting_period

type kind =
  | Proposal  (** protocols can be proposed *)
  | Testing_vote  (** a proposal can be voted *)
  | Testing  (** winning proposal is forked on a testnet *)
  | Promotion_vote  (** activation can be voted *)

val kind_encoding : kind Data_encoding.t
Voting_period_repr_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.

Parameter t : Set.

Definition voting_period := t.

Parameter encoding : Data_encoding.t voting_period.

Parameter rpc_arg : RPC_arg.arg voting_period.

Parameter pp : Format.formatter -> voting_period -> unit.

Parameter Included_S : {_ : unit & Compare.S.signature voting_period}.

Definition op_eq := (|Included_S|).(Compare.S.op_eq).

Definition op_ltgt := (|Included_S|).(Compare.S.op_ltgt).

Definition op_lt := (|Included_S|).(Compare.S.op_lt).

Definition op_lteq := (|Included_S|).(Compare.S.op_lteq).

Definition op_gteq := (|Included_S|).(Compare.S.op_gteq).

Definition op_gt := (|Included_S|).(Compare.S.op_gt).

Definition compare := (|Included_S|).(Compare.S.compare).

Definition equal := (|Included_S|).(Compare.S.equal).

Definition max := (|Included_S|).(Compare.S.max).

Definition min := (|Included_S|).(Compare.S.min).

Parameter to_int32 : voting_period -> int32.

Parameter of_int32_exn : int32 -> voting_period.

Parameter root : voting_period.

Parameter succ : voting_period -> voting_period.

Inductive kind : Set :=
| Proposal : kind
| Testing_vote : kind
| Testing : kind
| Promotion_vote : kind.

Parameter kind_encoding : Data_encoding.t kind.

Voting_services

  • OCaml size: 123 lines
  • Coq size: 294 lines (+139% compared to OCaml)
voting_services.ml 105 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

module S = struct
  let path = RPC_path.(open_root / "votes")

  let ballots =
    RPC_service.get_service
      ~description:"Sum of ballots casted so far during a voting period."
      ~query:RPC_query.empty
      ~output:Vote.ballots_encoding
      RPC_path.(path / "ballots")

  let ballot_list =
    RPC_service.get_service
      ~description:"Ballots casted so far during a voting period."
      ~query:RPC_query.empty
      ~output:
        Data_encoding.(
          list
            (obj2
               (req "pkh" Signature.Public_key_hash.encoding)
               (req "ballot" Vote.ballot_encoding)))
      RPC_path.(path / "ballot_list")

  let current_period_kind =
    RPC_service.get_service
      ~description:"Current period kind."
      ~query:RPC_query.empty
      ~output:Voting_period.kind_encoding
      RPC_path.(path / "current_period_kind")

  let current_quorum =
    RPC_service.get_service
      ~description:"Current expected quorum."
      ~query:RPC_query.empty
      ~output:Data_encoding.int32
      RPC_path.(path / "current_quorum")

  let listings =
    RPC_service.get_service
      ~description:
        "List of delegates with their voting weight, in number of rolls."
      ~query:RPC_query.empty
      ~output:Vote.listings_encoding
      RPC_path.(path / "listings")

  let proposals =
    RPC_service.get_service
      ~description:"List of proposals with number of supporters."
      ~query:RPC_query.empty
      ~output:(Protocol_hash.Map.encoding Data_encoding.int32)
      RPC_path.(path / "proposals")

  let current_proposal =
    RPC_service.get_service
      ~description:"Current proposal under evaluation."
      ~query:RPC_query.empty
      ~output:(Data_encoding.option Protocol_hash.encoding)
      RPC_path.(path / "current_proposal")
end

let register () =
  let open Services_registration in
  register0 S.ballots (fun ctxt () () -> Vote.get_ballots ctxt) ;
  register0 S.ballot_list (fun ctxt () () -> Vote.get_ballot_list ctxt >|= ok) ;
  register0 S.current_period_kind (fun ctxt () () ->
      Vote.get_current_period_kind ctxt) ;
  register0 S.current_quorum (fun ctxt () () -> Vote.get_current_quorum ctxt) ;
  register0 S.proposals (fun ctxt () () -> Vote.get_proposals ctxt) ;
  register0 S.listings (fun ctxt () () -> Vote.get_listings ctxt >|= ok) ;
  register0 S.current_proposal (fun ctxt () () ->
      (* this would be better implemented using get_option in get_current_proposal *)
      Vote.get_current_proposal ctxt
      >>= function
      | Ok p ->
          return_some p
      | Error (Raw_context.Storage_error (Missing_key _) :: _) ->
          return_none
      | Error _ as e ->
          Lwt.return e)

let ballots ctxt block = RPC_context.make_call0 S.ballots ctxt block () ()

let ballot_list ctxt block =
  RPC_context.make_call0 S.ballot_list ctxt block () ()

let current_period_kind ctxt block =
  RPC_context.make_call0 S.current_period_kind ctxt block () ()

let current_quorum ctxt block =
  RPC_context.make_call0 S.current_quorum ctxt block () ()

let listings ctxt block = RPC_context.make_call0 S.listings ctxt block () ()

let proposals ctxt block = RPC_context.make_call0 S.proposals ctxt block () ()

let current_proposal ctxt block =
  RPC_context.make_call0 S.current_proposal ctxt block () ()
Voting_services.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Services_registration.

Import Alpha_context.

Module S.
  Definition path : RPC_path.path Updater.rpc_context Updater.rpc_context :=
    RPC_path.op_div RPC_path.open_root "votes".
  
  Definition ballots
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      Updater.rpc_context unit unit Alpha_context.Vote.ballots :=
    RPC_service.get_service
      (Some "Sum of ballots casted so far during a voting period.")
      RPC_query.empty Alpha_context.Vote.ballots_encoding
      (RPC_path.op_div path "ballots").
  
  Definition ballot_list
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      Updater.rpc_context unit unit
      (list
        ((|Signature.Public_key_hash|).(S.SPublic_key_hash.t) *
          Alpha_context.Vote.ballot)) :=
    RPC_service.get_service
      (Some "Ballots casted so far during a voting period.") RPC_query.empty
      (Data_encoding.__list_value None
        (Data_encoding.obj2
          (Data_encoding.req None None "pkh"
            (|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding))
          (Data_encoding.req None None "ballot"
            Alpha_context.Vote.ballot_encoding)))
      (RPC_path.op_div path "ballot_list").
  
  Definition current_period_kind
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      Updater.rpc_context unit unit Alpha_context.Voting_period.kind :=
    RPC_service.get_service (Some "Current period kind.") RPC_query.empty
      Alpha_context.Voting_period.kind_encoding
      (RPC_path.op_div path "current_period_kind").
  
  Definition current_quorum
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      Updater.rpc_context unit unit int32 :=
    RPC_service.get_service (Some "Current expected quorum.") RPC_query.empty
      Data_encoding.__int32_value (RPC_path.op_div path "current_quorum").
  
  Definition listings
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      Updater.rpc_context unit unit
      (list ((|Signature.Public_key_hash|).(S.SPublic_key_hash.t) * int32)) :=
    RPC_service.get_service
      (Some "List of delegates with their voting weight, in number of rolls.")
      RPC_query.empty Alpha_context.Vote.listings_encoding
      (RPC_path.op_div path "listings").
  
  Definition proposals
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      Updater.rpc_context unit unit
      ((|Protocol_hash|).(S.HASH.Map).(S.INDEXES_Map.t) int32) :=
    RPC_service.get_service
      (Some "List of proposals with number of supporters.") RPC_query.empty
      ((|Protocol_hash|).(S.HASH.Map).(S.INDEXES_Map.encoding)
        Data_encoding.__int32_value) (RPC_path.op_div path "proposals").
  
  Definition current_proposal
    : RPC_service.service (* `GET *) unit Updater.rpc_context
      Updater.rpc_context unit unit (option (|Protocol_hash|).(S.HASH.t)) :=
    RPC_service.get_service (Some "Current proposal under evaluation.")
      RPC_query.empty
      (Data_encoding.__option_value (|Protocol_hash|).(S.HASH.encoding))
      (RPC_path.op_div path "current_proposal").
End S.

Definition register (function_parameter : unit) : unit :=
  let '_ := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  (* ❌ instruction_sequence ";" *)
  Services_registration.register0 S.current_proposal
    (fun ctxt =>
      fun function_parameter =>
        let '_ := function_parameter in
        fun function_parameter =>
          let '_ := function_parameter in
          Error_monad.op_gtgteq (Alpha_context.Vote.get_current_proposal ctxt)
            (fun function_parameter =>
              match function_parameter with
              | Pervasives.Ok p => Error_monad.return_some p
              | (Pervasives.Error _) as e => Lwt.__return e
              end)).

Definition ballots {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  : Lwt.t (Error_monad.shell_tzresult Alpha_context.Vote.ballots) :=
  RPC_context.make_call0 S.ballots ctxt block tt tt.

Definition ballot_list {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  : Lwt.t
    (Error_monad.shell_tzresult
      (list
        ((|Signature.Public_key_hash|).(S.SPublic_key_hash.t) *
          Alpha_context.Vote.ballot))) :=
  RPC_context.make_call0 S.ballot_list ctxt block tt tt.

Definition current_period_kind {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  : Lwt.t (Error_monad.shell_tzresult Alpha_context.Voting_period.kind) :=
  RPC_context.make_call0 S.current_period_kind ctxt block tt tt.

Definition current_quorum {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  : Lwt.t (Error_monad.shell_tzresult int32) :=
  RPC_context.make_call0 S.current_quorum ctxt block tt tt.

Definition listings {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  : Lwt.t
    (Error_monad.shell_tzresult
      (list ((|Signature.Public_key_hash|).(S.SPublic_key_hash.t) * int32))) :=
  RPC_context.make_call0 S.listings ctxt block tt tt.

Definition proposals {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  : Lwt.t
    (Error_monad.shell_tzresult
      ((|Protocol_hash|).(S.HASH.Map).(S.INDEXES_Map.t) int32)) :=
  RPC_context.make_call0 S.proposals ctxt block tt tt.

Definition current_proposal {D E G I K L a b c i o q : Set}
  (ctxt :
    (((RPC_service.t
      ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
        (* `POST *) unit + (* `PUT *) unit) RPC_context.t RPC_context.t q i o ->
    D -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
      (((RPC_service.t
        ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
          (* `POST *) unit + (* `PUT *) unit) RPC_context.t (RPC_context.t * a)
        q i o -> D -> a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) *
        (G * a * q * i * o)) *
        (((RPC_service.t
          ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
            (* `POST *) unit + (* `PUT *) unit) RPC_context.t
          ((RPC_context.t * a) * b) q i o -> D -> a -> b -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (I * a * b * q * i * o)) *
          (((RPC_service.t
            ((* `DELETE *) unit + (* `GET *) unit + (* `PATCH *) unit +
              (* `POST *) unit + (* `PUT *) unit) RPC_context.t
            (((RPC_context.t * a) * b) * c) q i o -> D -> a -> b -> c -> q ->
          i -> Lwt.t (Error_monad.shell_tzresult o)) *
            (K * a * b * c * q * i * o)) * L)))) * L * D) (block : D)
  : Lwt.t (Error_monad.shell_tzresult (option (|Protocol_hash|).(S.HASH.t))) :=
  RPC_context.make_call0 S.current_proposal ctxt block tt tt.

Voting_services_mli

  • OCaml size: 54 lines
  • Coq size: 183 lines (+238% compared to OCaml)
voting_services.mli 91 errors 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

val ballots : 'a #RPC_context.simple -> 'a -> Vote.ballots shell_tzresult Lwt.t

val ballot_list :
  'a #RPC_context.simple ->
  'a ->
  (Signature.Public_key_hash.t * Vote.ballot) list shell_tzresult Lwt.t

val current_period_kind :
  'a #RPC_context.simple -> 'a -> Voting_period.kind shell_tzresult Lwt.t

val current_quorum :
  'a #RPC_context.simple -> 'a -> Int32.t shell_tzresult Lwt.t

val listings :
  'a #RPC_context.simple ->
  'a ->
  (Signature.Public_key_hash.t * int32) list shell_tzresult Lwt.t

val proposals :
  'a #RPC_context.simple ->
  'a ->
  Int32.t Protocol_hash.Map.t shell_tzresult Lwt.t

val current_proposal :
  'a #RPC_context.simple -> 'a -> Protocol_hash.t option shell_tzresult Lwt.t

val register : unit -> unit
Voting_services_mli.v 
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Require Import TypingFlags.Loader.
Unset Guard Checking.

Require Import Tezos.Environment.
Require Tezos.Alpha_context.

Parameter ballots : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a ->
  Lwt.t (Error_monad.shell_tzresult Alpha_context.Vote.ballots).

Parameter ballot_list : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a ->
  Lwt.t
    (Error_monad.shell_tzresult
      (list
        ((|Signature.Public_key_hash|).(S.SPublic_key_hash.t) *
          Alpha_context.Vote.ballot))).

Parameter current_period_kind : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a ->
  Lwt.t (Error_monad.shell_tzresult Alpha_context.Voting_period.kind).

Parameter current_quorum : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a -> Lwt.t (Error_monad.shell_tzresult Int32.t).

Parameter listings : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a ->
  Lwt.t
    (Error_monad.shell_tzresult
      (list ((|Signature.Public_key_hash|).(S.SPublic_key_hash.t) * int32))).

Parameter proposals : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a ->
  Lwt.t
    (Error_monad.shell_tzresult
      ((|Protocol_hash|).(S.HASH.Map).(S.INDEXES_Map.t) Int32.t)).

Parameter current_proposal : forall {E F H J K a b c i o q : Set},
  (((RPC_service.t
    ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit +
      (* `PATCH *) unit) RPC_context.t RPC_context.t q i o -> a -> q -> i ->
  Lwt.t (Error_monad.shell_tzresult o)) * (E * q * i * o)) *
    (((RPC_service.t
      ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit + (* `POST *) unit
        + (* `PATCH *) unit) RPC_context.t (RPC_context.t * a) q i o -> a ->
    a -> q -> i -> Lwt.t (Error_monad.shell_tzresult o)) * (F * a * q * i * o))
      *
      (((RPC_service.t
        ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
          (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
        ((RPC_context.t * a) * b) q i o -> a -> a -> b -> q -> i ->
      Lwt.t (Error_monad.shell_tzresult o)) * (H * a * b * q * i * o)) *
        (((RPC_service.t
          ((* `PUT *) unit + (* `GET *) unit + (* `DELETE *) unit +
            (* `POST *) unit + (* `PATCH *) unit) RPC_context.t
          (((RPC_context.t * a) * b) * c) q i o -> a -> a -> b -> c -> q -> i ->
        Lwt.t (Error_monad.shell_tzresult o)) * (J * a * b * c * q * i * o)) * K))))
    * K * a -> a ->
  Lwt.t (Error_monad.shell_tzresult (option (|Protocol_hash|).(S.HASH.t))).

Parameter register : unit -> unit.

Sources are on GitHub. © Guillaume Claret.